From 234cfeabae97dc57cdc2d33a4af2188ade4603d2 Mon Sep 17 00:00:00 2001 From: Ken Johnson Date: Tue, 14 Apr 2026 10:45:31 -0700 Subject: [PATCH] Vendor WildCat 4 SDK as src/wc_sdk/, add to fpc.cfg search path --- docs/format-notes/dependencies.md | 14 +- fpc.cfg | 4 + src/wc_sdk/BILLGLO.C | 67 + src/wc_sdk/BILLGLO.DOC | 129 ++ src/wc_sdk/BILLGLO.H | 284 ++++ src/wc_sdk/BTDEFINE.PKG | 449 ++++++ src/wc_sdk/BTDEFINE.PRO | 449 ++++++ src/wc_sdk/DBIMPEXP.IN1 | 1120 +++++++++++++++ src/wc_sdk/DBIMPEXP.IN2 | 1372 ++++++++++++++++++ src/wc_sdk/EMSHEAP.CFG | 40 + src/wc_sdk/FILER.CFG | 92 ++ src/wc_sdk/FILER.MAK | 989 +++++++++++++ src/wc_sdk/FILERMAK.PRO | 989 +++++++++++++ src/wc_sdk/FVCBROWS.R16 | Bin 0 -> 413 bytes src/wc_sdk/FVCBROWS.R32 | Bin 0 -> 476 bytes src/wc_sdk/FVCBROWS.RC | 60 + src/wc_sdk/NUMKEYS.ASM | 509 +++++++ src/wc_sdk/NUMKEYS.OBJ | Bin 0 -> 992 bytes src/wc_sdk/OPBROW.ICD | 65 + src/wc_sdk/QXINDEX.INT | 32 + src/wc_sdk/QXINDEX.TPU | Bin 0 -> 16800 bytes src/wc_sdk/README.1ST | 142 ++ src/wc_sdk/TURBO.DSK | Bin 0 -> 1391 bytes src/wc_sdk/TURBO.TP | Bin 0 -> 4034 bytes src/wc_sdk/USERREC.CPP | 117 ++ src/wc_sdk/WC40REC.DOC | 575 ++++++++ src/wc_sdk/WCDOORS.DOC | 286 ++++ src/wc_sdk/WCMSGDB.DOC | 156 ++ src/wc_sdk/WCNET.DOC | 210 +++ src/wc_sdk/WCPAGEDB.DOC | 25 + src/wc_sdk/WCSTRING.H | 27 + src/wc_sdk/WCTYPE.C | 212 +++ src/wc_sdk/WCTYPE.H | 1018 +++++++++++++ src/wc_sdk/WCUSERDB.DOC | 116 ++ src/wc_sdk/basesupp.pas | 416 ++++++ src/wc_sdk/billglo.pas | 402 ++++++ src/wc_sdk/bldbrows.pas | 68 + src/wc_sdk/bldfiler.pas | 71 + src/wc_sdk/bldnettl.pas | 42 + src/wc_sdk/bldtools.pas | 51 + src/wc_sdk/brdefopt.inc | 59 + src/wc_sdk/brlisam.inc | 328 +++++ src/wc_sdk/browser.inc | 1347 +++++++++++++++++ src/wc_sdk/browser.pas | 916 ++++++++++++ src/wc_sdk/btbase.pas | 85 ++ src/wc_sdk/btdefine.inc | 491 +++++++ src/wc_sdk/btfileio.pas | 1296 +++++++++++++++++ src/wc_sdk/btisbase.pas | 942 ++++++++++++ src/wc_sdk/btlckmgr.inc | 737 ++++++++++ src/wc_sdk/bufrecio.pas | 640 +++++++++ src/wc_sdk/carrconv.pas | 1232 ++++++++++++++++ src/wc_sdk/convert.pas | 112 ++ src/wc_sdk/dbimpexp.pas | 1162 +++++++++++++++ src/wc_sdk/desq.pas | 131 ++ src/wc_sdk/dossupp.pas | 186 +++ src/wc_sdk/dpmi.pas | 763 ++++++++++ src/wc_sdk/emsheap.pas | 1576 ++++++++++++++++++++ src/wc_sdk/emssupp.pas | 245 ++++ src/wc_sdk/example.pas | 356 +++++ src/wc_sdk/filer.inc | 1815 +++++++++++++++++++++++ src/wc_sdk/filer.pas | 959 +++++++++++++ src/wc_sdk/fixtovar.pas | 110 ++ src/wc_sdk/fvcbrows.pas | 1767 +++++++++++++++++++++++ src/wc_sdk/fvcreg.pas | 51 + src/wc_sdk/hibrows.pas | 523 +++++++ src/wc_sdk/isambase.inc | 371 +++++ src/wc_sdk/isamlow.inc | 2121 +++++++++++++++++++++++++++ src/wc_sdk/isamnwrk.inc | 807 +++++++++++ src/wc_sdk/isamtool.pas | 874 ++++++++++++ src/wc_sdk/isamwork.inc | 2004 ++++++++++++++++++++++++++ src/wc_sdk/iscompat.pas | 1075 ++++++++++++++ src/wc_sdk/isnetsup.inc | 527 +++++++ src/wc_sdk/listfile.pas | 130 ++ src/wc_sdk/lowbrows.pas | 393 +++++ src/wc_sdk/medbrows.pas | 1244 ++++++++++++++++ src/wc_sdk/msgcheck.pas | 88 ++ src/wc_sdk/msgimprt.pas | 230 +++ src/wc_sdk/msort.pas | 1402 ++++++++++++++++++ src/wc_sdk/msortems.inc | 384 +++++ src/wc_sdk/msortinf.inc | 307 ++++ src/wc_sdk/msortp.pas | 1606 +++++++++++++++++++++ src/wc_sdk/netbios.pas | 1872 ++++++++++++++++++++++++ src/wc_sdk/netexamp.pas | 528 +++++++ src/wc_sdk/numkey32.pas | 821 +++++++++++ src/wc_sdk/numkeys.pas | 1034 ++++++++++++++ src/wc_sdk/nwbase.pas | 1381 ++++++++++++++++++ src/wc_sdk/nwbind.pas | 928 ++++++++++++ src/wc_sdk/nwconn.pas | 713 +++++++++ src/wc_sdk/nwfile.pas | 1171 +++++++++++++++ src/wc_sdk/nwipxspx.pas | 2222 +++++++++++++++++++++++++++++ src/wc_sdk/nwmsg.pas | 328 +++++ src/wc_sdk/nwprint.pas | 2082 +++++++++++++++++++++++++++ src/wc_sdk/nwsema.pas | 267 ++++ src/wc_sdk/nwtts.pas | 279 ++++ src/wc_sdk/oopsema.pas | 307 ++++ src/wc_sdk/opbrow.pas | 1524 ++++++++++++++++++++ src/wc_sdk/opdefine.inc | 152 ++ src/wc_sdk/qxindex.pas | 1092 ++++++++++++++ src/wc_sdk/qxstub.pas | 59 + src/wc_sdk/rebuild.pas | 83 ++ src/wc_sdk/reindex.pas | 553 +++++++ src/wc_sdk/reorg.pas | 87 ++ src/wc_sdk/restruct.pas | 495 +++++++ src/wc_sdk/sample.pas | 509 +++++++ src/wc_sdk/search.pas | 131 ++ src/wc_sdk/share.pas | 930 ++++++++++++ src/wc_sdk/tpalloc.pas | 526 +++++++ src/wc_sdk/tpcmd.pas | 540 +++++++ src/wc_sdk/tpdefine.inc | 130 ++ src/wc_sdk/tvbrows.pas | 1725 ++++++++++++++++++++++ src/wc_sdk/vrcompat.pas | 172 +++ src/wc_sdk/vrebuild.pas | 83 ++ src/wc_sdk/vrec.pas | 585 ++++++++ src/wc_sdk/vreorg.pas | 91 ++ src/wc_sdk/wbrowser.pas | 2068 +++++++++++++++++++++++++++ src/wc_sdk/wcdb.pas | 694 +++++++++ src/wc_sdk/wcfiledb.pas | 457 ++++++ src/wc_sdk/wcglobal.pas | 34 + src/wc_sdk/wcmisc.pas | 876 ++++++++++++ src/wc_sdk/wcmsgdb.pas | 997 +++++++++++++ src/wc_sdk/wcmsgex.pas | 203 +++ src/wc_sdk/wcpagedb.pas | 340 +++++ src/wc_sdk/wctrandb.pas | 108 ++ src/wc_sdk/wctype.pas | 1236 ++++++++++++++++ src/wc_sdk/wcuserdb.pas | 675 +++++++++ 125 files changed, 73071 insertions(+), 7 deletions(-) create mode 100644 src/wc_sdk/BILLGLO.C create mode 100644 src/wc_sdk/BILLGLO.DOC create mode 100644 src/wc_sdk/BILLGLO.H create mode 100644 src/wc_sdk/BTDEFINE.PKG create mode 100644 src/wc_sdk/BTDEFINE.PRO create mode 100644 src/wc_sdk/DBIMPEXP.IN1 create mode 100644 src/wc_sdk/DBIMPEXP.IN2 create mode 100644 src/wc_sdk/EMSHEAP.CFG create mode 100644 src/wc_sdk/FILER.CFG create mode 100644 src/wc_sdk/FILER.MAK create mode 100644 src/wc_sdk/FILERMAK.PRO create mode 100644 src/wc_sdk/FVCBROWS.R16 create mode 100644 src/wc_sdk/FVCBROWS.R32 create mode 100644 src/wc_sdk/FVCBROWS.RC create mode 100644 src/wc_sdk/NUMKEYS.ASM create mode 100644 src/wc_sdk/NUMKEYS.OBJ create mode 100644 src/wc_sdk/OPBROW.ICD create mode 100755 src/wc_sdk/QXINDEX.INT create mode 100644 src/wc_sdk/QXINDEX.TPU create mode 100755 src/wc_sdk/README.1ST create mode 100755 src/wc_sdk/TURBO.DSK create mode 100755 src/wc_sdk/TURBO.TP create mode 100755 src/wc_sdk/USERREC.CPP create mode 100755 src/wc_sdk/WC40REC.DOC create mode 100755 src/wc_sdk/WCDOORS.DOC create mode 100755 src/wc_sdk/WCMSGDB.DOC create mode 100644 src/wc_sdk/WCNET.DOC create mode 100644 src/wc_sdk/WCPAGEDB.DOC create mode 100755 src/wc_sdk/WCSTRING.H create mode 100755 src/wc_sdk/WCTYPE.C create mode 100755 src/wc_sdk/WCTYPE.H create mode 100755 src/wc_sdk/WCUSERDB.DOC create mode 100644 src/wc_sdk/basesupp.pas create mode 100644 src/wc_sdk/billglo.pas create mode 100644 src/wc_sdk/bldbrows.pas create mode 100644 src/wc_sdk/bldfiler.pas create mode 100644 src/wc_sdk/bldnettl.pas create mode 100644 src/wc_sdk/bldtools.pas create mode 100644 src/wc_sdk/brdefopt.inc create mode 100644 src/wc_sdk/brlisam.inc create mode 100644 src/wc_sdk/browser.inc create mode 100644 src/wc_sdk/browser.pas create mode 100644 src/wc_sdk/btbase.pas create mode 100644 src/wc_sdk/btdefine.inc create mode 100644 src/wc_sdk/btfileio.pas create mode 100644 src/wc_sdk/btisbase.pas create mode 100644 src/wc_sdk/btlckmgr.inc create mode 100644 src/wc_sdk/bufrecio.pas create mode 100644 src/wc_sdk/carrconv.pas create mode 100644 src/wc_sdk/convert.pas create mode 100644 src/wc_sdk/dbimpexp.pas create mode 100755 src/wc_sdk/desq.pas create mode 100644 src/wc_sdk/dossupp.pas create mode 100644 src/wc_sdk/dpmi.pas create mode 100644 src/wc_sdk/emsheap.pas create mode 100644 src/wc_sdk/emssupp.pas create mode 100644 src/wc_sdk/example.pas create mode 100644 src/wc_sdk/filer.inc create mode 100644 src/wc_sdk/filer.pas create mode 100644 src/wc_sdk/fixtovar.pas create mode 100644 src/wc_sdk/fvcbrows.pas create mode 100644 src/wc_sdk/fvcreg.pas create mode 100644 src/wc_sdk/hibrows.pas create mode 100644 src/wc_sdk/isambase.inc create mode 100644 src/wc_sdk/isamlow.inc create mode 100644 src/wc_sdk/isamnwrk.inc create mode 100644 src/wc_sdk/isamtool.pas create mode 100644 src/wc_sdk/isamwork.inc create mode 100644 src/wc_sdk/iscompat.pas create mode 100644 src/wc_sdk/isnetsup.inc create mode 100755 src/wc_sdk/listfile.pas create mode 100644 src/wc_sdk/lowbrows.pas create mode 100644 src/wc_sdk/medbrows.pas create mode 100755 src/wc_sdk/msgcheck.pas create mode 100755 src/wc_sdk/msgimprt.pas create mode 100644 src/wc_sdk/msort.pas create mode 100644 src/wc_sdk/msortems.inc create mode 100644 src/wc_sdk/msortinf.inc create mode 100644 src/wc_sdk/msortp.pas create mode 100644 src/wc_sdk/netbios.pas create mode 100644 src/wc_sdk/netexamp.pas create mode 100644 src/wc_sdk/numkey32.pas create mode 100644 src/wc_sdk/numkeys.pas create mode 100644 src/wc_sdk/nwbase.pas create mode 100644 src/wc_sdk/nwbind.pas create mode 100644 src/wc_sdk/nwconn.pas create mode 100644 src/wc_sdk/nwfile.pas create mode 100644 src/wc_sdk/nwipxspx.pas create mode 100644 src/wc_sdk/nwmsg.pas create mode 100644 src/wc_sdk/nwprint.pas create mode 100644 src/wc_sdk/nwsema.pas create mode 100644 src/wc_sdk/nwtts.pas create mode 100644 src/wc_sdk/oopsema.pas create mode 100644 src/wc_sdk/opbrow.pas create mode 100644 src/wc_sdk/opdefine.inc create mode 100644 src/wc_sdk/qxindex.pas create mode 100755 src/wc_sdk/qxstub.pas create mode 100644 src/wc_sdk/rebuild.pas create mode 100644 src/wc_sdk/reindex.pas create mode 100644 src/wc_sdk/reorg.pas create mode 100644 src/wc_sdk/restruct.pas create mode 100755 src/wc_sdk/sample.pas create mode 100755 src/wc_sdk/search.pas create mode 100644 src/wc_sdk/share.pas create mode 100644 src/wc_sdk/tpalloc.pas create mode 100644 src/wc_sdk/tpcmd.pas create mode 100644 src/wc_sdk/tpdefine.inc create mode 100644 src/wc_sdk/tvbrows.pas create mode 100644 src/wc_sdk/vrcompat.pas create mode 100644 src/wc_sdk/vrebuild.pas create mode 100644 src/wc_sdk/vrec.pas create mode 100644 src/wc_sdk/vreorg.pas create mode 100644 src/wc_sdk/wbrowser.pas create mode 100755 src/wc_sdk/wcdb.pas create mode 100755 src/wc_sdk/wcfiledb.pas create mode 100755 src/wc_sdk/wcglobal.pas create mode 100755 src/wc_sdk/wcmisc.pas create mode 100755 src/wc_sdk/wcmsgdb.pas create mode 100755 src/wc_sdk/wcmsgex.pas create mode 100644 src/wc_sdk/wcpagedb.pas create mode 100644 src/wc_sdk/wctrandb.pas create mode 100755 src/wc_sdk/wctype.pas create mode 100755 src/wc_sdk/wcuserdb.pas diff --git a/docs/format-notes/dependencies.md b/docs/format-notes/dependencies.md index 742ac09..c61d3ac 100644 --- a/docs/format-notes/dependencies.md +++ b/docs/format-notes/dependencies.md @@ -22,14 +22,14 @@ Plan: ## ma.fmt.wildcat.pas + ma.fmt.wcutil.pas -Currently use the WildCat SDK (`WcType`, `WcMsgDb`, `WcUserDb`, `WcGlobal`, -`WcMisc`, `WcDb`, `Os2Comp`, `DosUtil`, `p_System`). +Use the WildCat 4 SDK. The SDK source has been copied verbatim into +`src/wc_sdk/` (formerly `wc_dev/` in Allfix) so this repo can build the +Wildcat backend without external paths. -Plan: -- Treat the WC SDK as an optional dependency. Wrap the entire backend in - `{$IFDEF WILDCAT4}` so builds without the SDK still link. -- Document in `README.md` that Wildcat support requires the WC SDK source - on the FPC search path. +The SDK pulls in OS/2-era helpers (`Os2Comp`, `DosUtil`, `p_System`, +`btisbase`, `isamtool`, …). Keeping it on its own search-path entry +(`-Fusrc/wc_sdk`) means callers that don't need Wildcat can omit the +backend without forcing the SDK onto the build line. ## include.inc diff --git a/fpc.cfg b/fpc.cfg index 7eeb48c..7c26181 100644 --- a/fpc.cfg +++ b/fpc.cfg @@ -27,6 +27,10 @@ -Fusrc -Fusrc/formats +# WildCat 4 SDK (copied from Allfix wc_dev/) — only needed when building +# the Wildcat backend; harmless on its own. +-Fusrc/wc_sdk + # Output trees per target -FE./exe/$FPCTARGET -FU./units/$FPCTARGET diff --git a/src/wc_sdk/BILLGLO.C b/src/wc_sdk/BILLGLO.C new file mode 100644 index 0000000..110fb78 --- /dev/null +++ b/src/wc_sdk/BILLGLO.C @@ -0,0 +1,67 @@ +#include "billglo.h" + +const int MaxNodes = 250; +const char BillingPath[] = {"BILLING\\"}; + +const Str10 TProfileString[] = {"Post Pay", "Pre Pay"}; +const Str34 TCostString[] = {"Wildcat! account balance only", + "Wildcat! & billing credits balance", + "Billing credits balance only"}; + +const WORD bfHonorExpiredProfile = 0x0001; +const WORD bfReserved1 = 0x0002; +const WORD bfReserved2 = 0x0004; +const WORD bfReserved3 = 0x0008; +const WORD bfReserved4 = 0x0010; + +const Str19 TTransactionType[] = {"File Download", + "File Upload", + "Log on", + "Log off", + "Entered door", + "Exited door", + "Message written", + "Message read", + "Balance expired", + "Download attachment", + "Upload attachment", + "Payment", + "Miscellaneous", + "File Viewing", + "Entered Program", + "Exited Program", + "3rd Party 1", + "3rd Party 2", + "3rd Party 3", + "3rd Party 4", + "3rd Party 5", + "3rd Party 6", + "3rd Party 7", + "3rd Party 8", + "3rd Party 9", + "3rd Party 10"}; + +const Str04 ynbString[] = {"Yes", "No", "Both"}; +const Str24 condString[] = {"Greater than or equal to", + "Less than or equal to"}; + +const Str15 ReportString[] = {"DBF", + "Comma Delimited", + "Fixed Length", + "Invoice"}; + +const Str18 HandlingString[] = {"Mark As Processed", + "Don\'t Change", + "Delete Transaction"}; + +const Str09 OutputActionString[] = {"Append", + "Overwrite"}; + +const Str15 OutputFormatString[] = {"File or Printer", + "EMail Message"}; + +const Str05 SymbolLocationString[] = {"Left", "Right"}; + +const Str28 LogHandlingString[] = {"Append to *.BAK", + "Overwrite & rename to *.BAK", + "Erase during process"}; diff --git a/src/wc_sdk/BILLGLO.DOC b/src/wc_sdk/BILLGLO.DOC new file mode 100644 index 0000000..d70771d --- /dev/null +++ b/src/wc_sdk/BILLGLO.DOC @@ -0,0 +1,129 @@ + wcBILLING structures documentation + Responsibility: Sam Robertson + +This file attempts to document the Pascal structures defined within +BILLGLO.PAS. This document assumes a basic knowledge of Pascal as well +as knowledge of how to write a program to read and write fixed length +binary files. What is conveyed here is not necessarily documentation of +each field, but the caveats of the design as well as the important steps +one must take when changing information used by wcBILLING. + +With the exception of the files that explicitely say differently, all +files are stored within a directly below the Wildcat Home Directory +called 'BILLING\'. For Example - 'C:\WILDCAT\BILLING'. The BILLING\ +directory is not configurable and is hard-coded within the wcBILLING +program as well as Wildcat, the Wildcat utilities and doors. + +TBillProfile is a binary file containing one record of size +'TBillProfile'. Contains the billing profile pointed to in the +SECLEVEL.DAT file. It also contains the names of the corresponding +conference/file area/door and wcCODE billing rate configuration files. +This file is read directly by Wildcat, wcBILLING, wcMAIL, wcCHAT and +wcFAX. The bFlags variable near the end of the record is manipulated in +the same manner as the flag variables in MAKEWILD.DAT, CONFDESC.DAT and +so on. For further information on how to change this variable, see the +documentation in the WC40REC.ZIP file. + +Please note, that if a security profile does not explicitely define a +billing profile, or if the billing profile does not exist, Wildcat will +not process any transactions for the user. This is an important point, +because Wildcat does not have a default billing structure. A default +billing structure would be impossible to design with the amount of +flexibility we have attempted to add to wcBILLING. + +TConfProfile is a flat file database containing records corresponding to +each conference in the CONFDESC.DAT file. This file contains the +billing rates for each conference. You will notice that we duplicate +the conference name as well as the total number of conferences in each +record. This is done as a sanity header, and must match exactly the +name in the CONFDESC.DAT file. The Maximum number of conferences must +match exactly the value in the same field in the MAKEWILD.DAT file. The +filler space at the end of the record is for future expansion by MSI, +and 3rd party authors should contact MSI prior to using any of the bytes +in this field. + +TFileProfile is a flat file database similar in nature to TConfProfile, +and contains records corresponding to each file area defined in +FILEAREA.DAT. This file contains the file billing rates for each area. +You will notice, again, that the area name as well as the maximum number +of file areas is duplicated in this file like TConfProfile. Again, +these values must match the corresponding values in FILEAREA.DAT and +MAKEWILD.DAT. The record contains a filler field at the end, which is +reserved for expansion by MSI, any 3rd party authors should contact MSI +prior to using any of the bytes in this field. + +TDoorProfile is a flat file database similar in nature to TFileProfile. +This file contains billing rates information for each door defined in +the DOOR.DAT. Remember that Doors/Menu Hooks are both stored in +DOOR.DAT and should be treated the same way with respect to manipulating +this file. Again a filler space is provided at the bottom of each record +cotaining bytes to be used in a future version of wcBILLING. 3rd Party +authors should contact MSI prior to using any of the bytes in this +field. + +TCodeprofile is a new flat file database similar in nature to the other +billing rates in the system, however since this file is created +dynamically we do not store the total number of code programs in each +record as we do above. Filler space has been added at the end of the +record and should be left alone. Should you wish to use the filler +space, please contact MSI before beginning. + +The TTransactionRec is stored as a BTREE Filer database. For further +information regarding the manipulation of a BTREE Filer Database, see +the documentation in the WC40REC.ZIP file. This Filer database is a +fixed length flat file design with certain keyed fields. All keys use +the CStyle formatting similar to the Users Database/Files Database BTree +filer database defined in WC40REC.ZIP. See wcTRANDB.PAS for a decendant +of WCDB that will manipulate the Transaction database. This transaction +database is stored by the name of BILLING.DAT/IX/DIA. + +The TTransactionType enumeration contains 26 basic transaction types. +3rd party authors should use ttMiscellaneous or tt3rd1-tt3rd10 for all +transactions that don't fit within any of the other transaction types +when adding transaction records. All programs that manipulate the +transaction database need to document within the Comment field of the +Transaction Record, what the transaction is for. Also, All 3rd party +authors writing in Pascal, C or even wcCODE should deduct their +transaction amount prior to adding this record to the transaction +database. + +The TTransactionMatchRec record is stored as a binary file with size +equivalent to the record type. This record can be saved in any +directory and must contain the extension of '.BTM'. The BTM acronym +stands for Billing Transaction Match file. + +The TReportRecord is stored as a binary file with size equivalent to the +record size. This record is saved in any directory, and must contain +the extension of 'BEX' for an Export Transactions file or 'RPT' for a +Create reports configuration file. Options available are different for +each format and should be obvious. + +TImportRec is stored as a binary file with size equivalent to the record +size, and is stored in any directory, and must contain the extension of +'BIM'. + +TBillingSetup is stored as a binary file with size equivalent to the +record size. This record is saved in the BILLING\ directory, and must +be named 'BILLING.SUP'. This file contains the main configuration for +number types and the location and display of currency symbols. + +Command files are actually stored as straight ascii text files to +provide easy manipulation using a standard text editor. These files are +all stored with the extension of 'BCF' which stands for 'Billing Command +File'. These files are modeled after wcPRO in design, and should be easy +to understand and manipulate. + +For further information, please contact MSI through EMail. + +====================== Version 4.12 Specifics ====================== + +Not only did we add the new CodeProfile Billing Rates configuration, but +we also expanded the File Billing Rates record to include a new field +for viewing a file. With this release, we also doubled the number of +transaction types available with 10 set aside entirely for the 3rd Party +developers. + +The new field added to the File rates record, should be processed for +simply viewing the record, it is not based on size or how long the file +took to view, it is a flat charge or credit. + diff --git a/src/wc_sdk/BILLGLO.H b/src/wc_sdk/BILLGLO.H new file mode 100644 index 0000000..a0ed1ed --- /dev/null +++ b/src/wc_sdk/BILLGLO.H @@ -0,0 +1,284 @@ +/************************************************ + + Global record structures for wcBILLING! version 4.12 + Copyright 1986,95 Mustang Software Inc. + All rights reserved. + + Last Revised: 06-10-95 + Revision: 'B' + Responsibility: Sam Robertson + +************************************************/ + +#include "wcstring.h" + +typedef unsigned char BYTEBOOL; +typedef unsigned int WORD; +typedef unsigned char BYTE; + +typedef WORD Date; +typedef long Time; + +typedef struct tagTDateTime { + Date D; + Time T; +} TDateTime; + +#define MaxDays 7 +enum DayType {Sunday, + Monday, + Tuesday, + Wednesday, + Thursday, + Friday, + Saturday}; + +#define MaxHolidays 100 /* constant dictating the number of holidays */ +extern const int MaxNodes; /* Max possible number of nodes on BBS */ +extern const char BillingPath[]; /* Location of billing files from within Wildcat! */ + +enum TProfileType { ptPostPay, /* You accrue a balance then you pay */ + ptPrePay }; /* You start off with a balance and you run out */ + +typedef struct tagTExceptionTimeDays +{ + Time Start; /* Start Time */ + Time Ending; /* End Time */ + Str08 BillingProfile; /* Profile to use */ +} TExceptionTimeDays; + +typedef struct tagTHolidays +{ + Str08 DateMask; /* 11-25-** */ + Str08 BillingProfile; /* Profile to use */ +} THolidays; + +typedef THolidays THolidaysArray[MaxHolidays]; + +enum TCostHandling { fcWildcatOnly, /* Charge only to Wildcat! Balance */ + fcWildcatBilling, /* Charge to both Wildcat! and Billing */ + fcBillingOnly}; /* Charge only to Billing */ + +extern const Str10 TProfileString[]; +extern const Str34 TCostString[]; + +extern const WORD bfHonorExpiredProfile; /* When account balance is out, use expired security profile */ +extern const WORD bfReserved1; /* Reserved for future use */ +extern const WORD bfReserved2; /* Reserved for future use */ +extern const WORD bfReserved3; /* Reserved for future use */ +extern const WORD bfReserved4; /* Reserved for future use */ + +typedef struct tagTBillProfile /* filename: .DAT */ +{ + Str04 Version; /* Version Number */ + Str08 ProfileName; /* Name of profile */ + BYTE ProfileType; /* Type of billing (TProfileType) */ + Str08 ConferenceProfile; /* Conference Profile */ + Str08 FileProfile; /* File Areas Profile */ + Str08 DoorProfile; /* Doors Profile */ + int RegularRates; /* Regular increment rates */ + int ChatRates; /* rates while in wcCHAT */ + int FaxRates; /* rates while in wcFAX */ + int wcMailRates; /* rates while in wcMAIL */ + TExceptionTimeDays ExceptionRates[MaxDays]; /* Exception rates */ + THolidaysArray HolidayRates; /* Holiday increment rates */ + long Threshholds[2]; /* Display file when threshhold is met */ + long PostPayCap; /* Credit limit for post pay */ + int CreditValue; /* Value of credit to 1 unit of currency */ + int EnterChat; /* Cost to enter wcCHAT */ + int EnterFax; /* Cost to enter wcFAX */ + int EnterMail; /* Cost to enter wcMAIL */ + WORD bFlags; /* Flags */ + BYTE FaxCostHandling; /* FAX costs apply to what? (TCostHandling) */ + Str08 CodeProfile; /* wcCODE program profile. !!.412 */ +} TBillProfile; + +typedef struct tagTConfProfile /* filename: .CNF */ +{ + Str25 ConferenceName; /* Conference Name */ + int MsgWrittenRates; /* Messages Written Rate */ + int MsgKByteWrittenRates; /* Message KByte Rate */ + int UploadAttachment; /* Attachment Rate */ + int UploadAttachmentKByte; /* KBytes for Attachments */ + int MsgReadRates; /* Message Read Rates */ + int MsgKByteReadRates; /* Message KByte Rate */ + int DownloadAttachment; /* Attachment Rates */ + int DownloadAttachmentKByte; /* Download Attach KByte Rate */ + WORD MaxConferences; /* Sanity Filter */ + char Filler[44]; /* Filler */ +} TConfProfile; + +typedef struct tagTFileProfile /* filename: .FAR */ +{ + Str30 FileAreaName; /* File Area Name */ + int FileDownloadRate; /* Download Rate */ + int DownloadKByteRate; /* Download KByte Rate */ + int DownloadMByteRate; /* Download MByte Rate */ + int FileUploadRate; /* Upload Rate */ + int UploadKByteRate; /* Upload KByte Rate */ + int UploadMByteRate; /* Upload MByte Rate */ + WORD MaxFileAreas; /* Sanity Check */ + char Filler[43]; /* Filler */ +} TFileProfile; + +typedef struct tagTDoorProfile /* filename: .DOR */ +{ + Str20 DoorName; /* Door name */ + int DoorPMRate; /* Rate per minute in door */ + int CostToEnter; /* Cost to enter this door */ + WORD TotalDoors; /* Total Number of doors in profile */ + char Filler[42]; /* Filler */ +} TDoorProfile; + +typedef struct tagTCodeProfile /* filename: .WCD */ +{ + Str08 ProgramName; /* WCCODE Program Name */ + int ProgramPMRate; /* Per minute rate in wcCODE program */ + int CostToEnter; /* Cost to enter this wcCODE program */ + char Filler[256]; /* Filler space reserved for future use */ +} TCodeProfile; + +#define TotalTransactionTypes 26; +enum TTransactionType { ttFileDownload, + ttFileUpload, + ttLogin, + ttLogOff, + ttEnterDoor, + ttReturnFromDoor, + ttMessageWritten, + ttMessageRead, + ttBalanceExpired, + ttDownloadAttach, + ttUploadAttach, + ttPayment, + ttMiscellaneous, + ttFileView, /*!!.412*/ + ttEnterCodeProgram, /*!!.412*/ + ttReturnFromCodeProgram, /*!!.412*/ +/*************************************************************************** +* * +* The following transaction types are not used anywhere in wcBilling and * +* can be used by any 3rd party programs. Remember that if you add a * +* transaction of one of these types, you need to make sure and fill in the * +* Comment field as to what created the transaction as well as what the * +* transaction is for. * +* * +***************************************************************************/ + tt3rd1, /*Reserved for 3rd Party Apps !!.412*/ + tt3rd2, /*Reserved for 3rd Party Apps !!.412*/ + tt3rd3, /*Reserved for 3rd Party Apps !!.412*/ + tt3rd4, /*Reserved for 3rd Party Apps !!.412*/ + tt3rd5, /*Reserved for 3rd Party Apps !!.412*/ + tt3rd6, /*Reserved for 3rd Party Apps !!.412*/ + tt3rd7, /*Reserved for 3rd Party Apps !!.412*/ + tt3rd8, /*Reserved for 3rd Party Apps !!.412*/ + tt3rd9, /*Reserved for 3rd Party Apps !!.412*/ + tt3rd10}; /*Reserved for 3rd Party Apps !!.412*/ + +extern const Str19 TTransactionString[]; + +typedef struct tagTTransactionRec /* filename: BILLING.DAT;BILLING.IX;BILLING.DIA */ +{ + long Status; + long Number; /* Transaction number */ + BYTEBOOL Processed; /* Have we invoiced this one already */ + Str08 Profile; + Str25 UserName; /* Name of user making transaction */ + long UserID; /* User ID of user making transaction */ + TDateTime DT; /* Date & Time of transaction */ + WORD NodeID; /* Current node number */ + int TransactionCost; /* Cost of transaction */ + BYTE TransactionType; /* Type of transaction (TTransactionType) */ + Str70 Comment1; /* Comments */ + TDateTime ProcessedDate; /* Date & Time we processed this transaction */ + char Filler[100]; /* Filler */ +} TTransactionRec; + +enum TYesNoBoth { Yes, No, Both }; +extern const Str04 ynbString[]; + +enum TConditionType { GreaterEqual, LessEqual }; +extern const Str24 condString[]; + +typedef struct tagTTransactionMatchRec /* filename: .BTM */ +{ + Str05 Version; + WORD NodeIdLo; + WORD NodeIdHi; + long NumberLo; + long NumberHi; + long UserIdLo; + long UserIdHi; + Str25 UserName; + WORD TransactionAge; + BYTE taCondition; /* TConditionType */ + int TransactionCostLo; + int TransactionCostHi; + WORD TransactionType; /* bitset matching TTransactionType */ + Str70 Comment1; + BYTE Processed; /* TYesNoBoth */ + Date DTDateLo; + Date DTDateHi; + Date ProcessedDateLo; + Date ProcessedDateHi; + Str08 Profile; +} TTransactionMatchRec; + +enum TReport { tDBF, tComma, tFixed, tInvoice }; +extern const Str15 ReportString[]; + +enum THandling { tMarkAsProcessed, tDontChangeTRec, tDeleteTransaction }; +extern const Str18 HandlingString[]; + +enum TOutputAction { oAppend, oOverwrite }; +extern const Str09 OutputActionString[]; + +enum TOutputFormat { ofFile, ofEmail }; +extern const Str15 OutputFormatString[]; + +typedef struct tagTReportRecord +{ + Str05 Version; + BYTE Report; /* TReport */ + Str67 TemplateFileName; + Str67 OutputFileName; + BYTE OutputAction; /* TOutputAction */ + BYTE Handling; /* THandling */ + BYTE OutputFormat; /* TOutputFormat */ + WORD OutputConference; + Str70 OutputSubject; + Str70 OutputFrom; + long OutputFromId; + Str67 OverallTemplate; + BYTE OverallFormat; /* TOutputFormat */ + WORD OverallConference; + Str70 OverallSubject; + Str70 OverallTo; + long OverallToId; + Str67 OverallFileName; + BYTE OverallAction; /* TOutputAction */ +} TReportRecord; + +enum TSymbolLocation { slLeft, slRight }; +extern const Str05 SymbolLocationString[]; + +typedef struct tagTBillingSetup +{ + Str05 Version; + Str14 NumberFormat; + Str14 CurrencyFormat; + Str10 CurrencySymbol; + BYTE SymbolLocation; /* TSymbolLocation */ +} TBillingSetup; + +enum TLogHandling { lAppendToBackup, lRenameToBackup, lEraseLogs }; +extern const Str28 LogHandlingString[]; + +typedef struct tagTImportRec +{ + long Status; + int Cost; /* Cost of transaction */ + BYTE tType; /* Type of transaction (TTransactionType) */ + Str70 Comment1; /* Comments */ + Str67 ImportName; +} TImportRec; diff --git a/src/wc_sdk/BTDEFINE.PKG b/src/wc_sdk/BTDEFINE.PKG new file mode 100644 index 0000000..be72952 --- /dev/null +++ b/src/wc_sdk/BTDEFINE.PKG @@ -0,0 +1,449 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * Rob Roberts robr@pcisys.net + * + * ***** END LICENSE BLOCK ***** *) + +{---Conditional defines that affect B-Tree Filer units---} + + +{===B-Tree Filer defines=============================================} +{.$DEFINE NoNet} +{.$DEFINE Novell} +{$DEFINE MsNet} +{-Valid network interfaces. One or more must be defined, but NoNet + may not be selected except by itself. Novell is not valid for + 32-bit Delphi. For a real network, our recommendation is to always + use MsNet.} + +{$IFDEF Novell} +{.$DEFINE SupportVLM} +{-If compiling for Novell NetWare, defining SupportVLM will link in + the relevant NWXXXX units to support VLMs as well as NETX. This is + not an option for the DLL.} +{$ENDIF} + +{$IFNDEF DPMI} +{$IFNDEF Windows} +{$IFNDEF Win32} +{$DEFINE UseEMSHeap} +{-Adds code to the FILER unit to store page buffers in EMS in real + mode only. EMS cannot be used under Windows or DPMI.} +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{$IFDEF UseEMSHeap} +{.$DEFINE EMSDisturbance} +{-Adds code to save and restore the EMS page mapping.} +{$ENDIF} + +{.$DEFINE InitAllUnits} +{-Activate this define to cause all B-Tree Filer units to have an + initialization block, even if only an empty one. This works around + a bug in some very early versions of Borland's Turbo Debugger.} + +{$IFDEF Win32} +{$DEFINE SuppressWarnings} +{$ENDIF} +{-Activate this define to force Delphi 2.0 and 3.0 to display all + Hints and Warnings} + +{-Note: the defines for DebugEMSHeap, NoErrorCheckEMSHeap, + ManualInitEMSHeap, UseTPEMS, and UseOPEMS have been moved into + EMSHEAP.PAS, which is the only unit they affect.} + +{====================================================================} + + +{===Common defines between static/dynamic linked B-Tree Filer========} + +{$IFNDEF NoNet} +{.$DEFINE LockBeforeRead} +{-Automatically locks any file section before reading it, then + unlocks. May be needed to avoid a bug in some versions of the + NetWare NETX shell.} +{$ENDIF} + +{$DEFINE LengthByteKeys} +{.$DEFINE AsciiZeroKeys} +{-One of LengthByteKeys or AsciiZeroKeys must be defined, but not + both. LengthByteKeys causes B-Tree Filer to store Turbo Pascal style + strings in the index file. AsciiZeroKeys causes B-Tree Filer to + store C-style ASCIIZ strings in the index file.} + +{.$DEFINE UseTPCRT} +{.$DEFINE UseOPCRT} +{-Either UseTPCRT or UseOPCRT may be defined, but not both. These + defines affect the BROWSER unit only (and programs using BROWSER, + for example NETDEMO). Don't activate either one if the program uses + neither the TPCRT nor OPCRT units from Turbo Professional and + Object Professional, respectively.} + +{====================================================================} + +(********************************************************************) +(********************************************************************) +{Don't change anything beyond this point} + +{The following define allows extensions to B-Tree Filer to detect the + new syntax of versions 5.2 and later.} + +{$DEFINE BTree52} + +{The following define allows extensions to B-Tree Filer to detect the + new syntax of versions 5.4 and later.} + +{$DEFINE BTree54} + +{--Define whether a DPMI or Windows compiler is used} + {$IFDEF Windows} + {$DEFINE DPMIOrWnd} + {$ENDIF} + {$IFDEF DPMI} + {$DEFINE DPMIOrWnd} + {$ENDIF} + {$IFDEF Win32} + {$DEFINE DPMIOrWnd} + {$ENDIF} + +{--Define the syntax of BTInitIsam to be used} + {$IFDEF Windows} + {$DEFINE UseWindowsInit} + {$ENDIF} + {$IFDEF Win32} + {$DEFINE UseWindowsInit} + {$ENDIF} + +{--Check for .NET} {!!.57} + {$IFDEF CLR} {!!.57} + !! B-Tree Filer does not support .NET {!!.57} + {$ENDIF} {!!.57} + +{--Define whether using Delphi} + {$IFDEF VER80} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER90} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER100} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER120} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER130} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER140} {!!.56} + {$DEFINE UsingDelphi} {!!.56} + {$ENDIF} {!!.56} + {$IFDEF VER150} {!!.56} + {$DEFINE UsingDelphi} {!!.56} + {$ENDIF} {!!.56} + {$IFDEF VER170} {!!.57} + {$DEFINE UsingDelphi} {!!.57} + {$ENDIF} {!!.57} + {$IFDEF VER180} {!!.57a} + {$DEFINE UsingDelphi} {!!.57a} + {$ENDIF} {!!.57a} + +{--Define whether overlays can be allowed} + {$IFDEF MSDOS} + {$DEFINE CanAllowOverlays} + {$ELSE} + {$UNDEF CanAllowOverlays} + {$ENDIF} + +{--Test the definition of the net interfaces} + {$IFDEF Novell} + {$DEFINE RealNetDefined} + {$ENDIF} + {$IFDEF MsNet} + {$DEFINE RealNetDefined} + {$ENDIF} + + {$IFDEF NoNet} + {$IFDEF RealNetDefined} + !! ERROR: You may not define NoNet and any other Net simultaneously + {$ENDIF} + {$ELSE} + {$IFNDEF RealNetDefined} + !! ERROR: You must define either NoNet or at least one real network + {$ENDIF} + {$ENDIF} + {$UNDEF RealNetDefined} + +{--Test the XXKeys defines} + {$IFDEF LengthByteKeys} + {$IFDEF ASCIIZeroKeys} + !! ERROR: You may not define both LengthByteKeys and AsciiZeroKeys + {$ENDIF} + {$ELSE} + {$IFNDEF ASCIIZeroKeys} + !! ERROR: You must define either LengthByteKeys or AsciiZeroKeys + {$ENDIF} + {$ENDIF} + +{--Test the UseXXCrt defines} + {$IFDEF UseTPCRT} + {$IFDEF UseOPCRT} + !! ERROR: You may not define both UseTPCrt and UseOPCrt + {$ENDIF} + {$ENDIF} + +{--Test the FILER.MAK directives} + {$IFDEF TProOnly} + {$IFNDEF UseTPCrt} + !! ERROR: You must define UseTPCRT if compiling with TPro + {$ENDIF} + {$ENDIF} + {$IFDEF OProOnly} + {$IFNDEF UseOPCrt} + !! ERROR: You must define UseOPCRT if compiling with OPro + {$ENDIF} + {$ENDIF} + +{--Test for Win32 exclusions} + + {$IFDEF Win32} + {$IFDEF Novell} + !! ERROR: Novell network type is not available for 32-bit Delphi + {$ENDIF} + {$IFDEF UseTPCRT} + {$UNDEF UseTPCrt} + {$ENDIF} + {$IFDEF UseOPCRT} + {$UNDEF UseOPCrt} + {$ENDIF} + {$ENDIF} + +{--Win32 hints/warnings} + + {$IFDEF Win32} + {$IFDEF SuppressWarnings} + {$WARNINGS OFF} + {$HINTS OFF} + {$ELSE} + {$WARNINGS ON} + {$HINTS ON} + {$ENDIF} + {$ENDIF} + +{===Compiler options (not to be changed)=============================} +{$IFDEF VER70} {Borland Pascal 7.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$I-} {suppress I/O checking} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$S-} {stack checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$ENDIF} + +{$IFDEF VER80} {Delphi 1.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$G+} {generate 80286 code} +{$I-} {suppress I/O checking} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$S-} {stack checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi1} +{$DEFINE Delphi1Plus} +{$ENDIF} + +{$IFDEF VER90} {Delphi 2.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi2} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$ENDIF} + +{$IFDEF VER100} {Delphi 3.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi3} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$ENDIF} + +{$IFDEF VER120} {Delphi 4.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi4} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$ENDIF} + +{$IFDEF VER130} {Delphi 5.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi5} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$ENDIF} + +{$IFDEF VER140} {Delphi 6.0} {new !!.56} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi6} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$DEFINE Delphi6Plus} +{$ENDIF} + +{$IFDEF VER150} {Delphi 7.0} {new !!.56} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi7} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$DEFINE Delphi6Plus} +{$DEFINE Delphi7Plus} +{$ENDIF} + +{$IFDEF VER170} {Delphi 2005} {!!.57} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi2005} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$DEFINE Delphi6Plus} +{$DEFINE Delphi7Plus} +{$DEFINE Delphi2005Plus} +{$ENDIF} + +{$IFDEF VER180} {Delphi 2006} {!!.57a} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi2006} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$DEFINE Delphi6Plus} +{$DEFINE Delphi7Plus} +{$DEFINE Delphi2005Plus} +{$DEFINE Delphi2006Plus} +{$ENDIF} + diff --git a/src/wc_sdk/BTDEFINE.PRO b/src/wc_sdk/BTDEFINE.PRO new file mode 100644 index 0000000..8d64f0e --- /dev/null +++ b/src/wc_sdk/BTDEFINE.PRO @@ -0,0 +1,449 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * Rob Roberts robr@pcisys.net + * + * ***** END LICENSE BLOCK ***** *) + +{---Conditional defines that affect B-Tree Filer units---} + + +{===B-Tree Filer defines=============================================} +{$DEFINE NoNet} +{.$DEFINE Novell} +{.$DEFINE MsNet} +{-Valid network interfaces. One or more must be defined, but NoNet + may not be selected except by itself. Novell is not valid for + 32-bit Delphi. For a real network, our recommendation is to always + use MsNet.} + +{$IFDEF Novell} +{.$DEFINE SupportVLM} +{-If compiling for Novell NetWare, defining SupportVLM will link in + the relevant NWXXXX units to support VLMs as well as NETX. This is + not an option for the DLL.} +{$ENDIF} + +{$IFNDEF DPMI} +{$IFNDEF Windows} +{$IFNDEF Win32} +{$DEFINE UseEMSHeap} +{-Adds code to the FILER unit to store page buffers in EMS in real + mode only. EMS cannot be used under Windows or DPMI.} +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{$IFDEF UseEMSHeap} +{.$DEFINE EMSDisturbance} +{-Adds code to save and restore the EMS page mapping.} +{$ENDIF} + +{.$DEFINE InitAllUnits} +{-Activate this define to cause all B-Tree Filer units to have an + initialization block, even if only an empty one. This works around + a bug in some very early versions of Borland's Turbo Debugger.} + +{$IFDEF Win32} +{$DEFINE SuppressWarnings} +{$ENDIF} +{-Activate this define to force Delphi 2.0 and 3.0 to display all + Hints and Warnings} + +{-Note: the defines for DebugEMSHeap, NoErrorCheckEMSHeap, + ManualInitEMSHeap, UseTPEMS, and UseOPEMS have been moved into + EMSHEAP.PAS, which is the only unit they affect.} + +{====================================================================} + + +{===Common defines between static/dynamic linked B-Tree Filer========} + +{$IFNDEF NoNet} +{.$DEFINE LockBeforeRead} +{-Automatically locks any file section before reading it, then + unlocks. May be needed to avoid a bug in some versions of the + NetWare NETX shell.} +{$ENDIF} + +{$DEFINE LengthByteKeys} +{.$DEFINE AsciiZeroKeys} +{-One of LengthByteKeys or AsciiZeroKeys must be defined, but not + both. LengthByteKeys causes B-Tree Filer to store Turbo Pascal style + strings in the index file. AsciiZeroKeys causes B-Tree Filer to + store C-style ASCIIZ strings in the index file.} + +{.$DEFINE UseTPCRT} +{.$DEFINE UseOPCRT} +{-Either UseTPCRT or UseOPCRT may be defined, but not both. These + defines affect the BROWSER unit only (and programs using BROWSER, + for example NETDEMO). Don't activate either one if the program uses + neither the TPCRT nor OPCRT units from Turbo Professional and + Object Professional, respectively.} + +{====================================================================} + +(********************************************************************) +(********************************************************************) +{Don't change anything beyond this point} + +{The following define allows extensions to B-Tree Filer to detect the + new syntax of versions 5.2 and later.} + +{$DEFINE BTree52} + +{The following define allows extensions to B-Tree Filer to detect the + new syntax of versions 5.4 and later.} + +{$DEFINE BTree54} + +{--Define whether a DPMI or Windows compiler is used} + {$IFDEF Windows} + {$DEFINE DPMIOrWnd} + {$ENDIF} + {$IFDEF DPMI} + {$DEFINE DPMIOrWnd} + {$ENDIF} + {$IFDEF Win32} + {$DEFINE DPMIOrWnd} + {$ENDIF} + +{--Define the syntax of BTInitIsam to be used} + {$IFDEF Windows} + {$DEFINE UseWindowsInit} + {$ENDIF} + {$IFDEF Win32} + {$DEFINE UseWindowsInit} + {$ENDIF} + +{--Check for .NET} {!!.57} + {$IFDEF CLR} {!!.57} + !! B-Tree Filer does not support .NET {!!.57} + {$ENDIF} {!!.57} + +{--Define whether using Delphi} + {$IFDEF VER80} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER90} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER100} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER120} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER130} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER140} {!!.56} + {$DEFINE UsingDelphi} {!!.56} + {$ENDIF} {!!.56} + {$IFDEF VER150} {!!.56} + {$DEFINE UsingDelphi} {!!.56} + {$ENDIF} {!!.56} + {$IFDEF VER170} {!!.57} + {$DEFINE UsingDelphi} {!!.57} + {$ENDIF} {!!.57} + {$IFDEF VER180} {!!.57a} + {$DEFINE UsingDelphi} {!!.57a} + {$ENDIF} {!!.57a} + +{--Define whether overlays can be allowed} + {$IFDEF MSDOS} + {$DEFINE CanAllowOverlays} + {$ELSE} + {$UNDEF CanAllowOverlays} + {$ENDIF} + +{--Test the definition of the net interfaces} + {$IFDEF Novell} + {$DEFINE RealNetDefined} + {$ENDIF} + {$IFDEF MsNet} + {$DEFINE RealNetDefined} + {$ENDIF} + + {$IFDEF NoNet} + {$IFDEF RealNetDefined} + !! ERROR: You may not define NoNet and any other Net simultaneously + {$ENDIF} + {$ELSE} + {$IFNDEF RealNetDefined} + !! ERROR: You must define either NoNet or at least one real network + {$ENDIF} + {$ENDIF} + {$UNDEF RealNetDefined} + +{--Test the XXKeys defines} + {$IFDEF LengthByteKeys} + {$IFDEF ASCIIZeroKeys} + !! ERROR: You may not define both LengthByteKeys and AsciiZeroKeys + {$ENDIF} + {$ELSE} + {$IFNDEF ASCIIZeroKeys} + !! ERROR: You must define either LengthByteKeys or AsciiZeroKeys + {$ENDIF} + {$ENDIF} + +{--Test the UseXXCrt defines} + {$IFDEF UseTPCRT} + {$IFDEF UseOPCRT} + !! ERROR: You may not define both UseTPCrt and UseOPCrt + {$ENDIF} + {$ENDIF} + +{--Test the FILER.MAK directives} + {$IFDEF TProOnly} + {$IFNDEF UseTPCrt} + !! ERROR: You must define UseTPCRT if compiling with TPro + {$ENDIF} + {$ENDIF} + {$IFDEF OProOnly} + {$IFNDEF UseOPCrt} + !! ERROR: You must define UseOPCRT if compiling with OPro + {$ENDIF} + {$ENDIF} + +{--Test for Win32 exclusions} + + {$IFDEF Win32} + {$IFDEF Novell} + !! ERROR: Novell network type is not available for 32-bit Delphi + {$ENDIF} + {$IFDEF UseTPCRT} + {$UNDEF UseTPCrt} + {$ENDIF} + {$IFDEF UseOPCRT} + {$UNDEF UseOPCrt} + {$ENDIF} + {$ENDIF} + +{--Win32 hints/warnings} + + {$IFDEF Win32} + {$IFDEF SuppressWarnings} + {$WARNINGS OFF} + {$HINTS OFF} + {$ELSE} + {$WARNINGS ON} + {$HINTS ON} + {$ENDIF} + {$ENDIF} + +{===Compiler options (not to be changed)=============================} +{$IFDEF VER70} {Borland Pascal 7.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$I-} {suppress I/O checking} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$S-} {stack checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$ENDIF} + +{$IFDEF VER80} {Delphi 1.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$G+} {generate 80286 code} +{$I-} {suppress I/O checking} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$S-} {stack checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi1} +{$DEFINE Delphi1Plus} +{$ENDIF} + +{$IFDEF VER90} {Delphi 2.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi2} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$ENDIF} + +{$IFDEF VER100} {Delphi 3.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi3} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$ENDIF} + +{$IFDEF VER120} {Delphi 4.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi4} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$ENDIF} + +{$IFDEF VER130} {Delphi 5.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi5} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$ENDIF} + +{$IFDEF VER140} {Delphi 6.0} {new !!.56} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi6} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$DEFINE Delphi6Plus} +{$ENDIF} + +{$IFDEF VER150} {Delphi 7.0} {new !!.56} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi7} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$DEFINE Delphi6Plus} +{$DEFINE Delphi7Plus} +{$ENDIF} + +{$IFDEF VER170} {Delphi 2005} {!!.57} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi2005} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$DEFINE Delphi6Plus} +{$DEFINE Delphi7Plus} +{$DEFINE Delphi2005Plus} +{$ENDIF} + +{$IFDEF VER180} {Delphi 2006} {!!.57a} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi2006} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$DEFINE Delphi6Plus} +{$DEFINE Delphi7Plus} +{$DEFINE Delphi2005Plus} +{$DEFINE Delphi2006Plus} +{$ENDIF} + diff --git a/src/wc_sdk/DBIMPEXP.IN1 b/src/wc_sdk/DBIMPEXP.IN1 new file mode 100644 index 0000000..60c2dc2 --- /dev/null +++ b/src/wc_sdk/DBIMPEXP.IN1 @@ -0,0 +1,1120 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + + Function BuildDBPartOfFieldList ( LHPtr : PListHeader ) : Integer; + + Var + i, + Len, + FieldOfs : Word; + DBFFBuf : DBaseFileField; + CurFNPtr, + LastFNPtr, + MemoFNPtr : PFieldNode; + TStr : String; + Dummy : Integer; + + Begin + IsamClearOK; + IsamLongSeek ( LHPtr^.DBHeaderPtr^.IFile, + SizeOf ( DBaseFileFullHeader )); + If Not IsamOK Then Begin + BuildDBPartOfFieldList := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + + FieldOfs := 0; + LastFNPtr := Nil; + MemoFNPtr := Nil; + LHPtr^.ListPtr := Nil; + BuildDBPartOfFieldList := -1; + For i := 0 To LHPtr^.DBHeaderPtr^.Fields Do Begin + If MaxAvail < SizeOf ( FieldNode ) Then Begin + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( CurFNPtr, SizeOf ( FieldNode ) ); + + If MaxAvail < SizeOf ( DBaseField ) Then Begin + FreeMem ( CurFNPtr, SizeOf ( FieldNode ) ); + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( CurFNPtr^.DBFieldPtr, SizeOf ( DBaseField )); + + CurFNPtr^.BTFieldPtr := Nil; + CurFNPtr^.NextPtr := Nil; + CurFNPtr^.DBFieldPtr^.NormalContents := True; + If i = 0 Then Begin + {-1st field is delete mark} + CurFNPtr^.DBFieldPtr^.Normal.FType := DelMarkFType; + CurFNPtr^.DBFieldPtr^.Normal.Width := 1; + CurFNPtr^.DBFieldPtr^.Normal.Decimals := 0; + CurFNPtr^.FieldName := DelMarkName; + End Else Begin + IsamBlockRead ( LHPtr^.DBHeaderPtr^.IFile, DBFFBuf, + SizeOf ( DBaseFileField ) ); + If Not IsamOK Then Begin + BuildDBPartOfFieldList := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + + CurFNPtr^.DBFieldPtr^.Normal.FType := DBFFBuf.FType; + CurFNPtr^.DBFieldPtr^.Normal.Width := DBFFBuf.Width; + CurFNPtr^.DBFieldPtr^.Normal.Decimals := DBFFBuf.Decimals; + Len := GetAZSLength ( @DBFFBuf.Name ); + If Len > DBFieldNameLen Then + Len := DBFieldNameLen; + Dummy := CArr2LBStr ( TStr, @DBFFBuf.Name, Len ); + CurFNPtr^.FieldName := TStr; + End; + CurFNPtr^.DBFieldPtr^.Normal.Offset := FieldOfs; + Inc ( FieldOfs, CurFNPtr^.DBFieldPtr^.Normal.Width ); + + If LHPtr^.ListPtr = Nil Then Begin + LHPtr^.ListPtr := CurFNPtr; + End Else Begin + If CurFNPtr^.DBFieldPtr^.Normal.FType = MemoFType Then Begin + If MemoFNPtr = Nil Then Begin + LastFNPtr^.NextPtr := CurFNPtr; + End Else Begin + MemoFNPtr^.NextPtr := CurFNPtr; + End; + End Else Begin + If LastFNPtr = Nil Then Begin + {-1st field node is a memo field} + CurFNPtr^.NextPtr := LHPtr^.ListPtr^.NextPtr; + LHPtr^.ListPtr := CurFNPtr; + End Else Begin + CurFNPtr^.NextPtr := LastFNPtr^.NextPtr; + LastFNPtr^.NextPtr := CurFNPtr; + End; + End; + End; + If CurFNPtr^.DBFieldPtr^.Normal.FType = MemoFType Then Begin + MemoFNPtr := CurFNPtr; + End Else Begin + LastFNPtr := CurFNPtr; + End; + End; + BuildDBPartOfFieldList := 0; + End; + + + Function DBaseUndoUse ( Var LHPtr : PListHeader ) : Integer; + + Begin + DBaseUndoUse := CloseDBaseFiles ( LHPtr ); + FreeListHeader ( LHPtr ); + End; + + + Function CreateListHeaderUseDBaseFiles ( Var LHPtr : PListHeader; + DBFileName : DBaseFileName; + MaxMemoSize : Word) : Integer; + + Var + Dummy, + Error : Integer; + + Begin + IsamClearOK; + If MaxAvail < SizeOf ( ListHeader ) Then Begin + CreateListHeaderUseDBaseFiles := -1; + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( LHPtr, SizeOf ( ListHeader ) ); + FillChar ( LHPtr^, SizeOf ( ListHeader ), 0 ); + LHPtr^.DBSource := True; + + If MaxAvail < SizeOf ( DBaseHeader ) Then Begin + FreeMem ( LHPtr, SizeOf ( ListHeader ) ); + LHPtr := Nil; + CreateListHeaderUseDBaseFiles := -1; + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( LHPtr^.DBHeaderPtr, SizeOf ( DBaseHeader ) ); + FillChar ( LHPtr^.DBHeaderPtr^, SizeOf ( DBaseHeader ), 0 ); + + DBFileName := IsamForceExtension ( DBFileName, DBDataExtension ); + IsamAssign ( LHPtr^.DBHeaderPtr^.IFile, DBFileName ); + IsamReset ( LHPtr^.DBHeaderPtr^.IFile, False, True ); + If Not IsamOK Then Begin + Error := IsamError; + CreateListHeaderUseDBaseFiles := BTIsamErrorClass; + Dummy := DBaseUndoUse ( LHPtr ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + IsamBlockRead ( LHPtr^.DBHeaderPtr^.IFile, + LHPtr^.DBHeaderPtr^.Header, SizeOf ( DBaseFileHeader ) ); + If Not IsamOK Then Begin + Error := IsamError; + CreateListHeaderUseDBaseFiles := BTIsamErrorClass; + Dummy := DBaseUndoUse ( LHPtr ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + + Case LHPtr^.DBHeaderPtr^.Header.DBaseVer And DB4DataAndMemo Of + DBDataOnly : Begin + LHPtr^.DBHeaderPtr^.DBVer := DBVersion3X; + End; + + DB4DataAndMemo, + DBDataAndMemo: Begin + If LHPtr^.DBHeaderPtr^.Header.DBaseVer = DB4DataAndMemo Then Begin + LHPtr^.DBHeaderPtr^.DBVer := DBVersion4X; + End Else Begin + LHPtr^.DBHeaderPtr^.DBVer := DBVersion3X; + End; + If MaxMemoSize <> 0 Then Begin + If MaxAvail < SizeOf ( DBaseMemo ) Then Begin + Dummy := DBaseUndoUse ( LHPtr ); + CreateListHeaderUseDBaseFiles := -1; + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( LHPtr^.DBHeaderPtr^.MemoPtr, SizeOf ( DBaseMemo ) ); + + DBFileName := IsamForceExtension ( DBFileName, DBMemoExtension ); + IsamAssign ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, DBFileName ); + IsamReset ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, False, True ); + If Not IsamOK Then Begin + Error := IsamError; + CreateListHeaderUseDBaseFiles := BTIsamErrorClass; + Dummy := DBaseUndoUse ( LHPtr ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + + IsamBlockRead ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, + LHPtr^.DBHeaderPtr^.MemoPtr^.Header, + SizeOf ( DBaseMemoHeader ) ); + If Not IsamOK Then Begin + Error := IsamError; + CreateListHeaderUseDBaseFiles := BTIsamErrorClass; + Dummy := DBaseUndoUse ( LHPtr ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + + If ( LHPtr^.DBHeaderPtr^.Header.DBaseVer And DB4DataAndMemo ) + = DBDataAndMemo Then Begin + {-dBASE III file with memo fields} + LHPtr^.DBHeaderPtr^.MemoPtr^.Header.BlockSize := + DBMinMemoRecSize; + End; + + LHPtr^.DBHeaderPtr^.MemoPtr^.MaxSize := MaxMemoSize; + LHPtr^.DBHeaderPtr^.MemoPtr^.Modified := False; + End Else Begin + LHPtr^.DBHeaderPtr^.MemoPtr := Nil; + End; + End; + + Else Begin + CreateListHeaderUseDBaseFiles := -1; + Dummy := DBaseUndoUse ( LHPtr ); + CallProcErrorHandler ( ERAbort, 0, DEBV ); + Exit; + End; + End; {Case} + + LHPtr^.DBHeaderPtr^.Fields := + ( LHPtr^.DBHeaderPtr^.Header.HeaderSize - + SizeOf ( DBaseFileFullHeader ) - 1 ) Div SizeOf ( DBaseFileField ); + LHPtr^.DBHeaderPtr^.RefNr := 1; + LHPtr^.DBHeaderPtr^.Modified := False; + Error := BuildDBPartOfFieldList ( LHPtr ); + If Error <> 0 Then Begin + CreateListHeaderUseDBaseFiles := Error; + Error := DBaseUndoUse ( LHPtr ); + Exit; + End; + If Not DBaseEOF ( LHPtr ) Then + Error := DBaseGo ( LHPtr, LHPtr^.DBHeaderPtr^.RefNr ); + CreateListHeaderUseDBaseFiles := 0; + End; + + + Function InsertAutoRelField ( LHPtr : PListHeader ) : Boolean; + + Var + CurFNPtr : PFieldNode; + + Begin + InsertAutoRelField := False; + + If MaxAvail < SizeOf ( FieldNode ) Then Exit; + GetMem ( CurFNPtr, SizeOf ( FieldNode ) ); + + If MaxAvail < SizeOf ( DBaseField ) Then Begin + FreeMem ( CurFNPtr, SizeOf ( FieldNode ) ); + Exit; + End; + GetMem ( CurFNPtr^.DBFieldPtr, SizeOf ( DBaseField ) ); + + CurFNPtr^.FieldName := AutoRelName; + CurFNPtr^.DBFieldPtr^.NormalContents := False; + CurFNPtr^.DBFieldPtr^.Auto.Relation := StartAutoRel; + CurFNPtr^.BTFieldPtr := Nil; + CurFNPtr^.NextPtr := LHPtr^.ListPtr^.NextPtr; + LHPtr^.ListPtr^.NextPtr := CurFNPtr; + InsertAutoRelField := True; + End; + + + Function DetermineCType ( FNPtr : PFieldNode; + AZStrs : Boolean ) : Boolean; + + Begin + DetermineCType := True; + + If FNPtr^.DBFieldPtr^.NormalContents Then Begin + Case FNPtr^.DBFieldPtr^.Normal.FType Of + DelMarkFType : Begin + FNPtr^.BTFieldPtr^.CType := ReservedCType; + Exit; + End; + + MemoFType : Begin + FNPtr^.BTFieldPtr^.CType := AZStringCType; + Exit; + End; + + CharFType : Begin + If FNPtr^.DBFieldPtr^.Normal.Width = 1 Then Begin + FNPtr^.BTFieldPtr^.CType := CharCType; + End Else Begin + If AZStrs Then Begin + FNPtr^.BTFieldPtr^.CType := AZStringCType; + End Else Begin + FNPtr^.BTFieldPtr^.CType := StringCType; + End; + Exit; + End; + End; + + LogicFType : Begin + FNPtr^.BTFieldPtr^.CType := BooleanCType; + Exit; + End; + + DateFType : Begin + FNPtr^.BTFieldPtr^.CType := DateCType; + Exit; + End; + + NumerFType, + FloatFType : Begin + If FNPtr^.DBFieldPtr^.Normal.Decimals = 0 Then Begin + If FNPtr^.DBFieldPtr^.Normal.Width < 3 Then Begin + FNPtr^.BTFieldPtr^.CType := ShortIntCType; + End Else If FNPtr^.DBFieldPtr^.Normal.Width < 5 Then Begin + FNPtr^.BTFieldPtr^.CType := IntegerCType; + End Else If FNPtr^.DBFieldPtr^.Normal.Width < 10 Then Begin + FNPtr^.BTFieldPtr^.CType := LongIntCType; + End Else If FNPtr^.DBFieldPtr^.Normal.Width < 12 Then Begin + FNPtr^.BTFieldPtr^.CType := RealCType; + End Else If FNPtr^.DBFieldPtr^.Normal.Width < 16 Then Begin + FNPtr^.BTFieldPtr^.CType := DoubleCType; + End Else If FNPtr^.DBFieldPtr^.Normal.Width < 21 Then Begin + FNPtr^.BTFieldPtr^.CType := ExtendedCType; + End Else Begin + FNPtr^.BTFieldPtr^.CType := ReservedCType; + DetermineCType := False; + End; + End Else Begin + If FNPtr^.DBFieldPtr^.Normal.Width < 8 Then Begin + FNPtr^.BTFieldPtr^.CType := SingleCType; + End Else If FNPtr^.DBFieldPtr^.Normal.Width < 12 Then Begin + FNPtr^.BTFieldPtr^.CType := RealCType; + End Else If FNPtr^.DBFieldPtr^.Normal.Width < 16 Then Begin + FNPtr^.BTFieldPtr^.CType := DoubleCType; + End Else If FNPtr^.DBFieldPtr^.Normal.Width < 21 Then Begin + FNPtr^.BTFieldPtr^.CType := ExtendedCType; + End Else Begin + FNPtr^.BTFieldPtr^.CType := ReservedCType; + DetermineCType := False; + End; + End; + Exit; + End; + + Else Begin + FNPtr^.BTFieldPtr^.CType := ReservedCType; + DetermineCType := False; + Exit; + End; + End; {Case} + End Else Begin + FNPtr^.BTFieldPtr^.CType := LongIntCType; + End; + End; + + + Function DetermineBufSize ( LHPtr : PListHeader; + FNPtr : PFieldNode ) : Word; + + Begin + Case FNPtr^.BTFieldPtr^.CType Of + ReservedCType : + DetermineBufSize := SizeOf ( LongInt ); + DateCType : + DetermineBufSize := SizeOf ( LongInt ); + TimeCType : + DetermineBufSize := SizeOf ( LongInt ); + StringCType : + DetermineBufSize := FNPtr^.DBFieldPtr^.Normal.Width + 1; + AZStringCType : Begin + If FNPtr^.DBFieldPtr^.Normal.FType = MemoFType Then Begin + If LHPtr^.DBHeaderPtr^.MemoPtr <> Nil Then Begin + DetermineBufSize := LHPtr^.DBHeaderPtr^.MemoPtr^.MaxSize; + End Else Begin + DetermineBufSize := 0; + End; + End Else Begin + DetermineBufSize := FNPtr^.DBFieldPtr^.Normal.Width + 1; + End; + End; + BooleanCType : + DetermineBufSize := SizeOf ( Boolean ); + CharCType : + DetermineBufSize := SizeOf ( Char ); + ByteCType : + DetermineBufSize := SizeOf ( Byte ); + ShortIntCType : + DetermineBufSize := SizeOf ( ShortInt ); + IntegerCType : + DetermineBufSize := SizeOf ( Integer ); + WordCType : + DetermineBufSize := SizeOf ( Word ); + LongIntCType : + DetermineBufSize := SizeOf ( LongInt ); + CompCType : + DetermineBufSize := SizeOf ( Comp ); + SingleCType : + DetermineBufSize := SizeOf ( Single ); + RealCType : + DetermineBufSize := SizeOf ( Real ); + DoubleCType : + DetermineBufSize := SizeOf ( Double ); + ExtendedCType: + DetermineBufSize := SizeOf ( Extended ); + Else + DetermineBufSize := 0; + End; + End; + + + Function CompleteDBaseList ( LHPtr : PListHeader; + AZStrs, + AutoRel : Boolean ) : Integer; + + Var + CurFNPtr : PFieldNode; + FieldOfs : LongInt; + + Begin + CompleteDBaseList := -1; + + If Not LHPtr^.DBSource Then Begin + CallProcErrorHandler ( ERAbort, 0, DELHNI ); + Exit; + End; + + If MaxAvail < SizeOf ( IsamHeader ) Then Begin + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( LHPtr^.BTHeaderPtr, SizeOf ( IsamHeader ) ); + + If AutoRel Then Begin + If Not InsertAutoRelField ( LHPtr ) Then Begin + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + End; + + FieldOfs := 0; + CurFNPtr := LHPtr^.ListPtr; + While ( CurFNPtr <> Nil ) And ( FieldOfs <= $FFF7 ) Do Begin + If MaxAvail < SizeOf ( IsamField ) Then Begin + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( CurFNPtr^.BTFieldPtr, Sizeof ( IsamField ) ); + + If Not DetermineCType ( CurFNPtr, AZStrs ) Then Begin + CallProcErrorHandler ( ERAbort, 0, DEWCT ); + Exit; + End; + + CurFNPtr^.BTFieldPtr^.BufSize := + DetermineBufSize ( LHPtr, CurFNPtr ); + CurFNPtr^.BTFieldPtr^.Offset := Word ( FieldOfs ); + CurFNPtr^.BTFieldPtr^.Width := CurFNPtr^.DBFieldPtr^.Normal.Width; + CurFNPtr^.BTFieldPtr^.Decimals := + CurFNPtr^.DBFieldPtr^.Normal.Decimals; + Inc ( FieldOfs, CurFNPtr^.BTFieldPtr^.BufSize ); + CurFNPtr := CurFNPtr^.NextPtr; + End; + + If FieldOfs > $FFF7 Then Begin + CallProcErrorHandler ( ERAbort, 0, DERSTL ); + Exit; + End; + + If FieldOfs < SizeOf ( IsamSmallInfoRec ) Then + FieldOfs := SizeOf ( IsamSmallInfoRec ); + + LHPtr^.BTHeaderPtr^.DatSLen := Word ( FieldOfs ); + CompleteDBaseList := 0; + End; + + + Function WriteNoTypeDef ( LHPtr : PListHeader; + IFName : IsamFileName ) : Integer; + + Begin + End; + + + Procedure UndoWriteFile ( Var SFile : Text; + FName : IsamFileName ); + + Begin + Close ( SFile ); + Erase ( SFile ); + End; + + + Function WritePascalTypeDef ( LHPtr : PListHeader; + IFName : IsamFileName ) : Integer; + + Var + FNPtr : PFieldNode; + TypeFName, + FName : IsamFileName; + TypeFile : Text; + + Begin + WritePascalTypeDef := -1; + + TypeFName := StrUpCase ( IsamForceExtension ( IFName, {!!.42mod} + PasIncExtension )); + Assign ( TypeFile, TypeFName ); + Rewrite ( TypeFile ); + If IOResult <> 0 Then Exit; + + Writeln ( TypeFile, '{' + #13 + #10 + + ' Record type description of file ' + + StrUpCase ( IFName ) + {!!.42mod} + #13 + #10 + '}' + #13 + #10 ); + If IOResult <> 0 Then Begin + UndoWriteFile ( TypeFile, TypeFName ); + Exit; + End; + + FName := GetFNameOnly ( TypeFName ); + Writeln ( TypeFile, 'Const' + #13 + #10 + ' ' + FName + + 'DatSLen : Word = ', LHPtr^.BTHeaderPtr^.DatSLen, ';' + + #13 + #10 ); + If IOResult <> 0 Then Begin + UndoWriteFile ( TypeFile, TypeFName ); + Exit; + End; + Writeln ( TypeFile, 'Type' + #13 + #10 + ' ' + FName + + 'DatSType = Record' ); + If IOResult <> 0 Then Begin + UndoWriteFile ( TypeFile, TypeFName ); + Exit; + End; + + FNPtr := LHPtr^.ListPtr; + While FNPtr <> Nil Do Begin + If DetermineBufSize (LHPtr, FNPtr) <> 0 Then Begin + {-Is zero if no memo fields are converted (parameter MaxMemoSize + for CreateListHeaderUseDBaseFiles is zero)} + Case FNPtr^.BTFieldPtr^.CType Of + ReservedCType : + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : LongInt;' + #13 + #10 + ' { ReservedCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + DateCType : + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : LongInt;' + #13 + #10 + ' { DateCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + TimeCType : + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : LongInt;' + #13 + #10 + ' { TimeCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + StringCType : + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : String [', DetermineBufSize ( LHPtr, FNPtr ) - 1, '];' + + #13 + #10 + ' { StringCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + AZStringCType : + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : Array [0 .. ', DetermineBufSize (LHPtr, FNPtr) - 1, + '] Of Char;' + #13 + #10 + ' { AZStringCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + BooleanCType : + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : Boolean;' + #13 + #10 + ' { BooleanCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + CharCType : + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : Char;' + #13 + #10 + ' { CharCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + ByteCType : + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : Byte;' + #13 + #10 + ' { ByteCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + ShortIntCType : + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : ShortInt;' + #13 + #10 + + ' { ShortIntCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + IntegerCType : + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : Integer;' + #13 + #10 + ' { IntegerCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + WordCType : + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : Word;' + #13 + #10 + ' { WordCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + LongIntCType : + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : LongInt;' + #13 + #10 + ' { LongIntCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + CompCType: + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : Comp;' + #13 + #10 + ' { CompCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + SingleCType : + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : Single;' + #13 + #10 + ' { SingleCType; offset =', + FNPtr^.BTFieldPtr^.Offset, ' }'); + RealCType: + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : Real;' + #13 + #10 + ' { RealCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + DoubleCType: + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : Double;' + #13 + #10 + ' { DoubleCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + ExtendedCType: + Writeln ( TypeFile, ' ' : 4, FNPtr^.FieldName + #9 + + ' : Extended;' + #13 + #10 + + ' { ExtendedCType; offset = ', + FNPtr^.BTFieldPtr^.Offset, ' }' ); + Else Begin + UndoWriteFile ( TypeFile, TypeFName ); + Exit; + End; + End; {Case} + End; + + If IOResult <> 0 Then Begin + UndoWriteFile ( TypeFile, TypeFName ); + Exit; + End; + + FNPtr := FNPtr^.NextPtr; + End; + + Writeln ( TypeFile, ' End;' ); + If IOResult <> 0 Then Begin + UndoWriteFile ( TypeFile, TypeFName ); + Exit; + End; + + Close ( TypeFile ); + If IOResult <> 0 Then Begin + UndoWriteFile ( TypeFile, TypeFName ); + Exit; + End; + + WritePascalTypeDef := 0; + End; + + + Function DBaseReadRecord ( LHPtr : PListHeader; + Var BufPtr ) : Integer; + + Begin + DBaseReadRecord := 0; + IsamClearOK; + IsamBlockRead ( LHPtr^.DBHeaderPtr^.IFile, BufPtr, + LHPtr^.DBHeaderPtr^.Header.RecordSize ); + If Not IsamOK Then Begin + DBaseReadRecord := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + End; + + + Function DBaseReadMemoRec ( LHPtr : PListHeader; + RefNr : LongInt; + Var Buf ) : Integer; + + + Function DBase3ReadMemoRec ( LHPtr : PListHeader; + RefNr : LongInt; + Var Buf ) : Integer; + + Var + Idx : Word; + + Begin + IsamClearOK; + IsamLongSeek ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, + DBMinMemoRecSize * RefNr ); + If Not IsamOK Then Begin + DBase3ReadMemoRec := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + IsamBlockRead ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, Buf, + LHPtr^.DBHeaderPtr^.MemoPtr^.MaxSize ); + If Not IsamOK Then Begin + If IsamError <> 10070 Then Begin + DBase3ReadMemoRec := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End + End; + + Idx := BytePosInMem ( Byte ( DBEndOfMemoRec ), @Buf, + LHPtr^.DBHeaderPtr^.MemoPtr^.MaxSize ); + + {--Errorcode 10070 without DBEndOfMemoRec indicates defective memo file} + If ( IsamError = 10070 ) And + ( CharArr ( Buf ) [Idx] <> DBEndOfMemoRec ) Then Begin + DBase3ReadMemoRec := -1; + CallProcErrorHandler ( ERAbort, 0, DECMF ); + Exit; + End; + + If Idx <> LHPtr^.DBHeaderPtr^.MemoPtr^.MaxSize Then + Dec ( Idx ); + CharArr ( Buf ) [Idx] := #0; + DBase3ReadMemoRec := 0; + End; + + + Function DBase4ReadMemoRec ( LHPtr : PListHeader; + RefNr : LongInt; + Var Buf ) : Integer; + + Var + MemoSize : Word; + FMRec : DBase4FirstMemoRec; + + Begin + IsamClearOK; + IsamLongSeek ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, + LHPtr^.DBHeaderPtr^.MemoPtr^.Header.BlockSize * RefNr ); + If Not IsamOK Then Begin + DBase4ReadMemoRec := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + + IsamBlockRead ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, FMRec, + SizeOf ( FMRec ) ); + If Not IsamOK Then Begin + DBase4ReadMemoRec := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + + If FMRec.Valid <> DB4ValidMemoField Then Begin + CallProcErrorHandler ( ERAbort, 0, DECMF ); + DBase4ReadMemoRec := -1; + Exit; + End; + + If LHPtr^.DBHeaderPtr^.MemoPtr^.MaxSize > FMRec.Width - + SizeOf ( FMRec ) Then Begin + MemoSize := Word ( FMRec.Width - SizeOf ( FMRec ) ); + End Else Begin + MemoSize := LHPtr^.DBHeaderPtr^.MemoPtr^.MaxSize; + End; + + IsamBlockRead ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, Buf, + MemoSize); + If Not IsamOK Then Begin + DBase4ReadMemoRec := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + + If LHPtr^.DBHeaderPtr^.MemoPtr^.MaxSize > FMRec.Width - + SizeOf ( FMRec ) Then Begin + CharArr ( Buf ) [MemoSize] := #0; + End Else Begin + CharArr ( Buf ) [MemoSize - 1] := #0; + End; + + DBase4ReadMemoRec := 0; + End; + + + Begin + Case LHPtr^.DBHeaderPtr^.Header.DBaseVer And DB4DataAndMemo Of + DBDataAndMemo : + DBaseReadMemoRec := DBase3ReadMemoRec ( LHPtr, RefNr, Buf ); + DB4DataAndMemo : + DBaseReadMemoRec := DBase4ReadMemoRec ( LHPtr, RefNr, Buf ); + Else Begin + CallProcErrorHandler ( ERAbort, 0, DEFCNMF ); + DBaseReadMemoRec := -1; + End; + End; + End; + + + Function DBase2Isam ( FNPtr : PFieldNode; + Var SrcBuf, + DstBuf; + ProcCArrConv : VoidFct_CharArrConvert ) + : Integer; + + Begin + Case FNPtr^.BTFieldPtr^.CType Of + ReservedCType : Begin + If FNPtr^.DBFieldPtr^.Normal.FType = DelMarkFType Then Begin + If Char ( SrcBuf ) = ' ' Then Begin + LongInt ( DstBuf ) := 0; + End Else Begin + LongInt ( DstBuf ) := -1; + End; + DBase2Isam := 0; + End Else Begin + DBase2Isam := -1; + End + End; + + DateCType : Begin + DBase2Isam := CArr2Date ( LongInt ( DstBuf ), @SrcBuf ); + End; + + TimeCType : Begin + DBase2Isam := CArr2Time ( LongInt ( DstBuf ), @SrcBuf ); + End; + + StringCType : Begin + DBase2Isam := CArr2LBStr ( String ( DstBuf ), @SrcBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + CallProcCArrConv ( ProcCArrConv, @CharArr ( DstBuf ) [1], + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + AZStringCType : Begin + DBase2Isam := CArr2AZStr ( @DstBuf, @SrcBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + CallProcCArrConv ( ProcCArrConv, @DstBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + BooleanCType : Begin + DBase2Isam := Char2Boolean ( Boolean ( DstBuf ), Char ( SrcBuf ) ); + End; + + ByteCType : Begin + DBase2Isam := CArr2Byte ( Byte ( DstBuf ), @SrcBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + CharCType : Begin + Char ( DstBuf ) := Char ( SrcBuf ); + CallProcCArrConv ( ProcCArrConv, @DstBuf, 1 ); + DBase2Isam := 0; + End; + + ShortIntCType : Begin + DBase2Isam := CArr2ShortInt ( ShortInt ( DstBuf ), @SrcBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + IntegerCType : Begin + DBase2Isam := CArr2Integer ( Integer ( DstBuf ), @SrcBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + WordCType : Begin + DBase2Isam := CArr2Word ( Word ( DstBuf ), @SrcBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + LongIntCType : Begin + DBase2Isam := CArr2LongInt ( LongInt ( DstBuf ), @SrcBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + SingleCType : Begin + DBase2Isam := CArr2Single ( Single ( DstBuf ), @SrcBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + DoubleCType : Begin + DBase2Isam := CArr2Double ( Double ( DstBuf ), @SrcBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + RealCType : Begin + DBase2Isam := CArr2Real ( Real ( DstBuf ), @SrcBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + ExtendedCType : Begin + DBase2Isam := CArr2Extended ( Extended ( DstBuf ), @SrcBuf, + FNPtr^.DBFieldPtr^.Normal.Width); + End; + + Else Begin + DBase2Isam := -1; + End; + End; + End; + + + Function CallFuncWriteTypeDef ( FuncWriteTypeDef : IntFct_WriteTDef; + LHPtr : PListHeader; + IFName : IsamFileName ) + : Integer; + + Begin + If (@FuncWriteTypeDef <> @WriteNoTypeDef ) And + (@FuncWriteTypeDef <> Nil) Then Begin + CallFuncWriteTypeDef := FuncWriteTypeDef ( LHPtr, IFName ); + End Else Begin + CallFuncWriteTypeDef := 0; + End; + End; + + + Function DBaseImport ( LHPtr : PListHeader; + IFBName : IsamFileBlockName; + FuncWriteTypeDef : IntFct_WriteTDef; + FuncReXUser : IntFct_ReXUser; + ProcCArrConv : VoidFct_CharArrConvert; + FuncDecideWrite : EnumFct_DecideWrite ) + : Integer; + + Type + PLongInt = ^LongInt; + + Var + BTBufPtr, + DBBufPtr : ^Char; + RefBuf, + ReadRecs, + WriteRecs, + ErrorRecs : LongInt; + ErrorFields, + Error : Integer; + UserAbort : Boolean; + CurFNPtr : PFieldNode; + TempFName : IsamFileName; + DummyIID : IsamIndDescr; + DumpFilePtr : PText; + + + Begin + DBaseImport := -1; + + If Not CheckListHeaderPtr ( LHPtr, True ) Then Begin + CallProcErrorHandler ( ERAbort, 0, DELHNI ); + Exit; + End; + + FillChar ( DummyIID, SizeOf ( IsamIndDescr ), 0 ); + BTCreateFileBlock ( IFBName, LHPtr^.BTHeaderPtr^.DatSLen, 0, DummyIID ); + If Not IsamOK Then Begin + DBaseImport := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + BTOpenFileBlock ( LHPtr^.BTHeaderPtr^.FBPtr, IFBName, False, + False, False, False ); + If Not IsamOK Then Begin + Error := IsamError; + DBaseImport := BTIsamErrorClass; + BTDeleteFileBlock ( IFBName ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + + If MaxAvail < LHPtr^.BTHeaderPtr^.DatSLen Then Begin + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( BTBufPtr, LHPtr^.BTHeaderPtr^.DatSLen ); + + If MaxAvail < LHPtr^.DBHeaderPtr^.Header.RecordSize Then Begin + UndoDBaseImpExp ( LHPtr, BTBufPtr, Nil, + LHPtr^.BTHeaderPtr^.DatSLen, 0 ); + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( DBBufPtr, LHPtr^.DBHeaderPtr^.Header.RecordSize ); + + If CallFuncWriteTypeDef ( FuncWriteTypeDef, LHPtr, + BTDataFileName ( LHPtr^.BTHeaderPtr^.FBPtr ) ) <> 0 Then Begin + CallProcErrorHandler ( ERIgnore, 0, DEEWTD ); + End; + + UserAbort := CallFuncReXUser ( FuncReXUser, WSInit, LHPtr, + LHPtr^.DBHeaderPtr^.Header.NrOfRecs, + LHPtr^.BTHeaderPtr^.DatSLen, 0, BTBufPtr^ ) <> 0; + + DumpFilePtr := Nil; + ReadRecs := 0; + WriteRecs := 0; + ErrorRecs := 0; + While ( Not DBaseEOF ( LHPtr ) ) And ( Not UserAbort ) Do Begin + If DBaseReadRecord ( LHPtr, DBBufPtr^ ) <> 0 Then Begin + Error := IsamError; + DBaseImport := BTIsamErrorClass; + UndoDBaseImpExp ( LHPtr, BTBufPtr, DBBufPtr, + LHPtr^.BTHeaderPtr^.DatSLen, + LHPtr^.DBHeaderPtr^.Header.RecordSize ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + + FillChar ( BTBufPtr^, LHPtr^.BTHeaderPtr^.DatSLen, 0 ); + ErrorFields := 0; + CurFNPtr := LHPtr^.ListPtr; + While CurFNPtr <> Nil Do Begin + With CurFNPtr^ Do Begin + If DBFieldPtr^.NormalContents Then Begin + {-dBASE fields including delete mark} + If DBFieldPtr^.Normal.FType <> MemoFType Then Begin + ConvStatus := DBase2Isam ( CurFNPtr, + PCharArr ( DBBufPtr )^ [DBFieldPtr^.Normal.Offset], + PCharArr ( BTBufPtr )^ [BTFieldPtr^.Offset], + ProcCArrConv ); + End Else Begin + If LHPtr^.DBHeaderPtr^.MemoPtr <> Nil Then Begin + ConvStatus := CArr2LongInt ( RefBuf, + @PCharArr ( DBBufPtr )^ [DBFieldPtr^.Normal.Offset], + DBFieldPtr^.Normal.Width ); + If ( ConvStatus = 0 ) And ( RefBuf <> 0 ) Then Begin + ConvStatus := DBaseReadMemoRec ( LHPtr, RefBuf, + PCharArr ( BTBufPtr )^ [BTFieldPtr^.Offset] ); + End; + End Else Begin + {-Memo fields are not converted (MaxMemoSize <> 0)} + ConvStatus := 0; + End; + End; + If ConvStatus <> 0 Then Begin + Inc ( ErrorFields ); + If ConvStatus > 0 Then Begin + UndoDBaseImpExp ( LHPtr, BTBufPtr, DBBufPtr, + LHPtr^.BTHeaderPtr^.DatSLen, + LHPtr^.DBHeaderPtr^.Header.RecordSize ); + DBaseImport := ConvStatus; + Exit; + End Else Begin + CallProcErrorHandler ( ERIgnore, 0, DEECF ); + End; + End; + End Else Begin + {-Auto relation field} + PLongInt ( @PCharArr ( BTBufPtr )^ [BTFieldPtr^.Offset] )^ := + DBFieldPtr^.Auto.Relation; + Inc ( DBFieldPtr^.Auto.Relation ); + End; + CurFNPtr := CurFNPtr^.NextPtr; + End; + End; + + If ErrorFields <> 0 Then Begin + Error := WriteDump ( DumpFilePtr, LHPtr, ErrorFields ); + Inc ( ErrorRecs ); + End; + + Case CallFuncDecideWrite ( FuncDecideWrite, LHPtr, ErrorFields, + BTBufPtr^, DBBufPtr^ ) Of + DCWrite : Begin + BTAddRec ( LHPtr^.BTHeaderPtr^.FBPtr, RefBuf, BTBufPtr^ ); + If Not IsamOK Then Begin + Error := IsamError; + DBaseImport := BTIsamErrorClass; + UndoDBaseImpExp ( LHPtr, BTBufPtr, DBBufPtr, + LHPtr^.BTHeaderPtr^.DatSLen, + LHPtr^.DBHeaderPtr^.Header.RecordSize ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + Inc ( WriteRecs ); + End; + + DCSkip : ; + + DCAbort : Exit; + + Else Begin + CallProcErrorHandler ( ERAbort, 0, DEPE ); + Exit; + End; + End; + + Inc ( ReadRecs ); + UserAbort := CallFuncReXUser ( FuncReXUser, WSWork, LHPtr, ReadRecs, + WriteRecs, ErrorRecs, BTBufPtr^ ) <> 0; + + Error := DBaseSkip ( LHPtr ); + If Error <> 0 Then Begin + UndoDBaseImpExp ( LHPtr, BTBufPtr, DBBufPtr, + LHPtr^.BTHeaderPtr^.DatSLen, + LHPtr^.DBHeaderPtr^.Header.RecordSize ); + DBaseImport := Error; + End; + End; + + UserAbort := CallFuncReXUser ( FuncReXUser, WSExit, LHPtr, ReadRecs, + WriteRecs, ErrorRecs, BTBufPtr^ ) <> 0; + + FreeMem ( DBBufPtr, LHPtr^.DBHeaderPtr^.Header.RecordSize ); + FreeMem ( BTBufPtr, LHPtr^.BTHeaderPtr^.DatSLen ); + + Error := CloseDumpFile ( DumpFilePtr ); + + DBaseImport := CloseIsamFiles ( LHPtr ); + End; diff --git a/src/wc_sdk/DBIMPEXP.IN2 b/src/wc_sdk/DBIMPEXP.IN2 new file mode 100644 index 0000000..6d350a7 --- /dev/null +++ b/src/wc_sdk/DBIMPEXP.IN2 @@ -0,0 +1,1372 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + + Function IsamUndoUse ( Var LHPtr : PListHeader ) : Integer; + + Begin + IsamUndoUse := CloseIsamFiles ( LHPtr ); + FreeListHeader ( LHPtr ); + End; + + + Function CreateListHeaderOpenFileBlock ( BTFileName : IsamFileBlockName ) + : PListHeader; + + Var + LHPtr : PListHeader; + Dummy, + Error : Integer; + + Begin + CreateListHeaderOpenFileBlock := Nil; + + If MaxAvail < SizeOf ( ListHeader ) Then Begin + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( LHPtr, SizeOf ( ListHeader ) ); + FillChar ( LHPtr^, SizeOf ( ListHeader ), 0 ); + LHPtr^.DBSource := False; + + If MaxAvail < SizeOf ( IsamHeader ) Then Begin + FreeMem ( LHPtr, SizeOf ( ListHeader ) ); + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( LHPtr^.BTHeaderPtr, SizeOf ( IsamHeader ) ); + FillChar ( LHPtr^.BTHeaderPtr^, SizeOf ( IsamHeader ), 0 ); + + BTOpenFileBlock ( LHPtr^.BTHeaderPtr^.FBPtr, BTFileName, + False, False, False, False ); + If Not IsamOK Then Begin + Error := IsamError; + Dummy := IsamUndoUse ( LHPtr ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + LHPtr^.BTHeaderPtr^.DatSLen := Word ( + BTDatRecordSize ( LHPtr^.BTHeaderPtr^.FBPtr ) ); + If Not IsamOK Then Begin + Error := IsamError; + Dummy := IsamUndoUse ( LHPtr ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + + CreateListHeaderOpenFileBlock := LHPtr; + End; + + + Function AddFieldNode ( Var LHPtr : PListHeader; + Name : DBaseFieldNameStr; + CType, + BufSize, + Offset : Word; + Width, + Decimals : Integer ) : Boolean; + + Var + CurFNPtr, + LastFNPtr : PFieldNode; + Dummy : Integer; + + Begin + AddFieldNode := False; + + Name := StrUpCase ( Name ); {!!.42mod} + CurFNPtr := LHPtr^.ListPtr; + LastFNPtr := LHPtr^.ListPtr; + While CurFNPtr <> Nil Do Begin + If CurFNPtr^.FieldName = Name Then Begin + CallProcErrorHandler ( ERAbort, 0, DEFNAE ); + Dummy := CloseIsamFiles ( LHPtr ); + FreeListHeader ( LHPtr ); + Exit; + End; + LastFNPtr := CurFNPtr; + CurFNPtr := CurFNPtr^.NextPtr; + End; + + If Offset + BufSize > LHPtr^.BTHeaderPtr^.DatSLen Then Begin + CallProcErrorHandler ( ERAbort, 0, DERSTL ); + Dummy := CloseIsamFiles ( LHPtr ); + FreeListHeader ( LHPtr ); + Exit; + End; + + If MaxAvail < SizeOf ( FieldNode ) Then Begin + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Dummy := CloseIsamFiles ( LHPtr ); + FreeListHeader ( LHPtr ); + Exit; + End; + GetMem ( CurFNPtr, SizeOf ( FieldNode ) ); + + If MaxAvail < SizeOf ( IsamField ) Then Begin + FreeMem ( CurFNPtr, SizeOf ( FieldNode ) ); + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Dummy := CloseIsamFiles ( LHPtr ); + FreeListHeader ( LHPtr ); + Exit; + End; + GetMem ( CurFNPtr^.BTFieldPtr, SizeOf ( IsamField ) ); + + CurFNPtr^.ConvStatus := 0; + CurFNPtr^.FieldName := Name; + CurFNPtr^.NextPtr := Nil; + CurFNPtr^.DBFieldPtr := Nil; + CurFNPtr^.BTFieldPtr^.CType := CType; + CurFNPtr^.BTFieldPtr^.BufSize := BufSize; + CurFNPtr^.BTFieldPtr^.Offset := Offset; + CurFNPtr^.BTFieldPtr^.Width := Width; + CurFNPtr^.BTFieldPtr^.Decimals := Decimals; + + If LastFNPtr = Nil Then Begin + LHPtr^.ListPtr := CurFNPtr; + End Else Begin + LastFNPtr^.NextPtr := CurFNPtr; + End; + + AddFieldNode := True; + End; + + + Function DetermineFTypeAndLen ( FNPtr : PFieldNode; + DBVer : DBaseVersion ) : Integer; + + Begin + DetermineFTypeAndLen := 0; + + Case FNPtr^.BTFieldPtr^.CType Of + ReservedCType : Begin + If (FNPtr^.BTFieldPtr^.Offset = 0) And + (FNPtr^.BTFieldPtr^.BufSize = SizeOf (LongInt) ) Then Begin + FNPtr^.DBFieldPtr^.Normal.FType := DelMarkFType; + FNPtr^.DBFieldPtr^.Normal.Width := 1; + FNPtr^.DBFieldPtr^.Normal.Decimals := 0; + End Else Begin + DetermineFTypeAndLen := -1; + End; + End; + + DateCType : Begin + FNPtr^.DBFieldPtr^.Normal.FType := DateFType; + FNPtr^.DBFieldPtr^.Normal.Width := 8; + FNPtr^.DBFieldPtr^.Normal.Decimals := 0; + End; + + TimeCType : Begin + FNPtr^.DBFieldPtr^.Normal.FType := CharFType; + FNPtr^.DBFieldPtr^.Normal.Width := 8; + FNPtr^.DBFieldPtr^.Normal.Decimals := 0; + End; + + StringCType : Begin + FNPtr^.DBFieldPtr^.Normal.FType := CharFType; + FNPtr^.DBFieldPtr^.Normal.Width := + FNPtr^.BTFieldPtr^.BufSize - 1; + FNPtr^.DBFieldPtr^.Normal.Decimals := 0; + End; + + AZStringCType : Begin + If FNPtr^.BTFieldPtr^.BufSize > 255 Then Begin + FNPtr^.DBFieldPtr^.Normal.FType := MemoFType; + FNPtr^.DBFieldPtr^.Normal.Width := DBMemoFieldWidth; + End Else Begin + FNPtr^.DBFieldPtr^.Normal.FType := CharFType; + FNPtr^.DBFieldPtr^.Normal.Width := + FNPtr^.BTFieldPtr^.BufSize - 1; + End; + FNPtr^.DBFieldPtr^.Normal.Decimals := 0; + End; + + BooleanCType : Begin + FNPtr^.DBFieldPtr^.Normal.FType := LogicFType; + FNPtr^.DBFieldPtr^.Normal.Width := 1; + FNPtr^.DBFieldPtr^.Normal.Decimals := 0; + End; + + CharCType : Begin + FNPtr^.DBFieldPtr^.Normal.FType := CharFType; + FNPtr^.DBFieldPtr^.Normal.Width := 1; + FNPtr^.DBFieldPtr^.Normal.Decimals := 0; + End; + + ByteCType : Begin + FNPtr^.DBFieldPtr^.Normal.FType := NumerFType; + If FNPtr^.BTFieldPtr^.Width <> -1 Then Begin + FNPtr^.DBFieldPtr^.Normal.Width := + FNPtr^.BTFieldPtr^.Width; + End Else Begin + FNPtr^.DBFieldPtr^.Normal.Width := 3; + End; + FNPtr^.DBFieldPtr^.Normal.Decimals := 0; + End; + + ShortIntCType : Begin + FNPtr^.DBFieldPtr^.Normal.FType := NumerFType; + If FNPtr^.BTFieldPtr^.Width <> -1 Then Begin + FNPtr^.DBFieldPtr^.Normal.Width := + FNPtr^.BTFieldPtr^.Width; + End Else Begin + FNPtr^.DBFieldPtr^.Normal.Width := 4; + End; + FNPtr^.DBFieldPtr^.Normal.Decimals := 0; + End; + + WordCType : Begin + FNPtr^.DBFieldPtr^.Normal.FType := NumerFType; + If FNPtr^.BTFieldPtr^.Width <> -1 Then Begin + FNPtr^.DBFieldPtr^.Normal.Width := + FNPtr^.BTFieldPtr^.Width; + End Else Begin + FNPtr^.DBFieldPtr^.Normal.Width := 5; + End; + FNPtr^.DBFieldPtr^.Normal.Decimals := 0; + End; + + IntegerCType : Begin + FNPtr^.DBFieldPtr^.Normal.FType := NumerFType; + If FNPtr^.BTFieldPtr^.Width <> -1 Then Begin + FNPtr^.DBFieldPtr^.Normal.Width := + FNPtr^.BTFieldPtr^.Width; + End Else Begin + FNPtr^.DBFieldPtr^.Normal.Width := 6; + End; + FNPtr^.DBFieldPtr^.Normal.Decimals := 0; + End; + + LongIntCType: Begin + FNPtr^.DBFieldPtr^.Normal.FType := NumerFType; + If FNPtr^.BTFieldPtr^.Width <> -1 Then Begin + FNPtr^.DBFieldPtr^.Normal.Width := + FNPtr^.BTFieldPtr^.Width; + End Else Begin + FNPtr^.DBFieldPtr^.Normal.Width := 11; + End; + FNPtr^.DBFieldPtr^.Normal.Decimals := 0; + End; + + CompCType, + RealCType, + SingleCType, + DoubleCType, + ExtendedCType : Begin + If DBVer = DBVersion4X Then Begin + FNPtr^.DBFieldPtr^.Normal.FType := FloatFType; + End Else Begin + FNPtr^.DBFieldPtr^.Normal.FType := NumerFType; + End; + If FNPtr^.BTFieldPtr^.Width <> -1 Then Begin + FNPtr^.DBFieldPtr^.Normal.Width := + FNPtr^.BTFieldPtr^.Width; + End Else Begin + FNPtr^.DBFieldPtr^.Normal.Width := 14; + End; + If FNPtr^.BTFieldPtr^.Decimals <> -1 Then Begin + FNPtr^.DBFieldPtr^.Normal.Decimals := + FNPtr^.BTFieldPtr^.Decimals; + End Else Begin + FNPtr^.DBFieldPtr^.Normal.Decimals := 4; + End; + End; + + Else Begin + DetermineFTypeAndLen := -1; + End; + End; {Case} + End; + + + Function CompleteIsamList ( LHPtr : PListHeader; + DBVer : DBaseVersion ) : Integer; + + Var + CurFNPtr : PFieldNode; + FieldOfs, + Size : Word; + Fields, + Error : Integer; + + Begin + CompleteIsamList := -1; + + If ( DBVer <> DBVersion3X ) And ( DBVer <> DBVersion4X ) Then Begin + CallProcErrorHandler ( ERAbort, 0, DEBV ); + Exit; + End; + + If LHPtr^.DBSource Then Begin + CallProcErrorHandler ( ERAbort, 0, DELHNI ); + Exit; + End; + + If MaxAvail < SizeOf ( DBaseHeader ) Then Begin + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( LHPtr^.DBHeaderPtr, SizeOf ( DBaseHeader ) ); + FillChar ( LHPtr^.DBHeaderPtr^, SizeOf ( DBaseHeader ), 0 ); + LHPtr^.DBHeaderPtr^.RefNr := 1; + LHPtr^.DBHeaderPtr^.DBVer := DBVer; + + FieldOfs := 1; + Fields := -1; + CurFNPtr := LHPtr^.ListPtr; + While ( CurFNPtr <> Nil ) And ( FieldOfs <= DBMaxRecSize ) Do Begin + If MaxAvail < SizeOf ( DBaseField ) Then Begin + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( CurFNPtr^.DBFieldPtr, SizeOf ( DBaseField ) ); + + Error := DetermineFTypeAndLen ( CurFNPtr, DBVer ); + If Error <> 0 Then Begin + CallProcErrorHandler ( ERAbort, 0, DEWCT ); + CompleteIsamList := Error; + Exit; + End; + + CurFNPtr^.ConvStatus := 0; + CurFNPtr^.DBFieldPtr^.NormalContents := True; + If CurFNPtr^.DBFieldPtr^.Normal.FType = DelMarkFType Then Begin + CurFNPtr^.DBFieldPtr^.Normal.Offset := 0; + End Else Begin + CurFNPtr^.DBFieldPtr^.Normal.Offset := FieldOfs; + Inc ( FieldOfs, CurFNPtr^.DBFieldPtr^.Normal.Width ); + Inc ( Fields ); + End; + + CurFNPtr := CurFNPtr^.NextPtr; + End; + + If FieldOfs > DBMaxRecSize Then Begin + CallProcErrorHandler ( ERAbort, 0, DERSTL ); + Exit; + End; + LHPtr^.DBHeaderPtr^.Header.RecordSize := FieldOfs; + + Error := 0; + If DBVer = DBVersion4X Then Begin + If Fields > DB4MaxFields Then Error := -1; + End Else Begin + If Fields > DBMaxFields Then Error := -1; + End; + If Error <> 0 Then Begin + CallProcErrorHandler ( ERAbort, 0, DETMF ); + CompleteIsamList := Error; + Exit; + End; + + LHPtr^.DBHeaderPtr^.Fields := Fields; + CompleteIsamList := 0; + End; + + + Function CheckAndSetFields ( LHPtr : PListHeader ) : Integer; + + Var + CurFNPtr : PFieldNode; + MaxFields : Integer; + + Begin + CheckAndSetFields := -1; + + If LHPtr^.DBHeaderPtr^.DBVer = DBVersion4X Then Begin + MaxFields := DB4MaxFields; + End Else Begin + MaxFields := DBMaxFields; + End; + + LHPtr^.DBHeaderPtr^.Fields := 0; + CurFNPtr := LHPtr^.ListPtr; + While ( CurFNPtr <> Nil ) And + ( LHPtr^.DBHeaderPtr^.Fields <= MaxFields ) Do Begin + Case CurFNPtr^.DBFieldPtr^.Normal.FType Of + DelMarkFType : {no action}; + + LogicFType, + DateFType, + CharFType, + MemoFType, + NumerFType, + FloatFType : Inc ( LHPtr^.DBHeaderPtr^.Fields ); + + Else Begin + {-Wrong field type} + CallProcErrorHandler ( ERAbort, 0, DEWFT ); + Exit; + End; + End; {Case} + + CurFNPtr := CurFNPtr^.NextPtr; + End; + + If LHPtr^.DBHeaderPtr^.Fields > MaxFields Then Begin + CallProcErrorHandler ( ERAbort, 0, DETMF ); + Exit; + End; + + CheckAndSetFields := 0; + End; + + + Function Str2DBFieldName ( Dst : Pointer; + Src : DBaseFieldNameStr ) : Pointer; + + Var + Len : Integer; + + Begin + Len := Length ( Src ); + Src := StrUpCase ( Src ); {!!.42mod} + Move ( Src [1], Dst^, Len ); + FillChar ( PCharArr ( Dst )^ [Len], DBFieldNameLen - Len + 1, 0 ); + Str2DBFieldName := Dst; + End; + + + Function CheckAndSetFieldContents ( FNPtr : PFieldNode; + DBFFPtr : PDBaseFileField; + DBVer : Integer; + Var UseMemoPtr : Boolean ) : Integer; + + Var + MaxWidth, + MaxDecimals : Integer; + DummyPtr : Pointer; + + Begin + CheckAndSetFieldContents := -1; + DummyPtr := Str2DBFieldName ( @DBFFPtr^.Name, FNPtr^.FieldName ); + DBFFPtr^.FType := FNPtr^.DBFieldPtr^.Normal.FType; + Case DBFFPtr^.FType Of + DelMarkFType : {no action}; + + CharFType : Begin + If FNPtr^.DBFieldPtr^.Normal.Width > DBMaxCharFieldWidth Then Begin + CallProcErrorHandler ( ERAbort, 0, DEFWTL ); + Exit; + End; + DBFFPtr^.Width := FNPtr^.DBFieldPtr^.Normal.Width; + DBFFPtr^.Decimals := 0; + End; + + FloatFType, + NumerFType : Begin + If ( DBFFPtr^.FType = FloatFType ) And ( DBVer <> DBVersion4X ) + Then Begin + CallProcErrorHandler ( ERAbort, 0, DEFTVC ); + Exit; + End; + + If DBVer = DBVersion4X Then Begin + MaxWidth := DB4MaxNumFieldWidth; + MaxDecimals := DB4MaxNumFieldDecimals; + End Else Begin + MaxWidth := DBMaxNumFieldWidth; + MaxDecimals := DBMaxNumFieldDecimals; + End; + If FNPtr^.DBFieldPtr^.Normal.Width > MaxWidth Then Begin + {-Field too large} + CallProcErrorHandler ( ERAbort, 0, DEFWTL ); + Exit; + End; + If FNPtr^.DBFieldPtr^.Normal.Decimals > 0 Then Begin + If ( FNPtr^.DBFieldPtr^.Normal.Decimals + 2 > + FNPtr^.DBFieldPtr^.Normal.Width ) Or + ( FNPtr^.DBFieldPtr^.Normal.Decimals > + MaxDecimals ) Then Begin + {-Too many decimals} + CallProcErrorHandler ( ERAbort, 0, DETMD ); + Exit; + End; + End; + DBFFPtr^.Width := FNPtr^.DBFieldPtr^.Normal.Width; + DBFFPtr^.Decimals := FNPtr^.DBFieldPtr^.Normal.Decimals; + End; + + LogicFType : Begin + DBFFPtr^.Width := DBLogicFieldWidth; + DBFFPtr^.Decimals := 0; + End; + + DateFType : Begin + DBFFPtr^.Width := DBDateFieldWidth; + DBFFPtr^.Decimals := 0; + End; + + MemoFType : Begin + UseMemoPtr := True; + DBFFPtr^.Width := DBMemoFieldWidth; + DBFFPtr^.Decimals := 0; + End; + + Else Begin + {-Wrong field type} + CallProcErrorHandler ( ERAbort, 0, DEWFT ); + Exit; + End; + End; {Case} + + FNPtr^.DBFieldPtr^.Normal.Width := DBFFPtr^.Width; + FNPtr^.DBFieldPtr^.Normal.Decimals := DBFFPtr^.Decimals; + CheckAndSetFieldContents := 0; + End; + + + Procedure DBaseWriteDummyBlock ( Var F : IsamFile; + Len : LongInt ); + + Const + EmptyArrLen = DBMinMemoRecSize; + + Var + EmptyArr : Array [1..EmptyArrLen] Of Char; + + Begin + FillChar ( EmptyArr, SizeOf ( EmptyArr ), 0 ); + While Len > EmptyArrLen Do Begin + IsamBlockWrite ( F, EmptyArr, SizeOf ( EmptyArr ) ); + If Not IsamOK Then Exit; + Len := Len - SizeOf ( EmptyArr ); + End; + IsamBlockWrite ( F, EmptyArr, Word ( Len ) ); + End; + + + Procedure UndoDBaseCreate ( DBFPtr : Pointer; + DBTPtr : Pointer; + DBFFArrPtr : PDBaseFileFieldArray; + DBFFArrSize : Word ); + + Type + IsamFilePtr = ^IsamFile; + + Begin + IsamClearOK; + + If DBFPtr <> Nil Then + IsamClose ( IsamFilePtr ( DBFPtr )^ ); + If DBTPtr <> Nil Then + IsamClose ( IsamFilePtr ( DBTPtr )^ ); + If DBFFArrPtr <> Nil Then + FreeMem ( DBFFArrPtr, DBFFArrSize ); + End; + + + Function DBaseCreate ( LHPtr : PListHeader; + DBFName : DBaseFileName ) : Integer; + + Var + UseMemo : Boolean; + Error, + DBFFArrIdx : Integer; + TerminateDBF : Array [0 .. 1] Of Char; + Header : DBaseFileFullHeader; + DBFFArrPtr : PDBaseFileFieldArray; + DBFFPtr : PDBaseFileField; + CurFNPtr : PFieldNode; + DBFFArrSize : Word; + + Begin + DBaseCreate := -1; + + IsamClearOK; + FillChar ( Header, SizeOf ( DBaseFileFullHeader ), 0 ); + + Error := CheckAndSetFields ( LHPtr ); + If Error <> 0 Then Begin + DBaseCreate := Error; + Exit; + End; + + If LHPtr^.DBHeaderPtr^.Fields = 0 Then Begin + CallProcErrorHandler ( ERAbort, 0, DENFD ); + Exit; + End; + + DBFFArrSize := LHPtr^.DBHeaderPtr^.Fields * SizeOf ( DBaseFileField ); + If MaxAvail < DBFFArrSize Then Begin + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( DBFFArrPtr, DBFFArrSize ); + FillChar ( DBFFArrPtr^, DBFFArrSize, 0 ); + + {--Build file field descriptor array} + UseMemo := False; + Header.Part.RecordSize := 1; + CurFNPtr := LHPtr^.ListPtr; + DBFFArrIdx := 0; + DBFFPtr := @DBFFArrPtr^ [0]; + While CurFNPtr <> Nil Do Begin + If Not CurFNPtr^.DBFieldPtr^.NormalContents Then Begin + {-Auto relation field is not allowed here} + UndoDBaseCreate ( Nil, Nil, DBFFArrPtr, DBFFArrSize ); + CallProcErrorHandler ( ERAbort, 0, DEARFNA ); + Exit; + End; + + If CurFNPtr^.DBFieldPtr^.Normal.FType <> DelMarkFType Then Begin + Error := CheckAndSetFieldContents ( CurFNPtr, DBFFPtr, + LHPtr^.DBHeaderPtr^.DBVer, UseMemo ); + If Error <> 0 Then Begin + UndoDBaseCreate ( Nil, Nil, DBFFArrPtr, DBFFArrSize ); + DBaseCreate := Error; + Exit; + End; + + Inc ( Header.Part.RecordSize, DBFFPtr^.Width ); + If Header.Part.RecordSize > DBMaxRecSize Then Begin + {-Record size too large} + UndoDBaseCreate ( Nil, Nil, DBFFArrPtr, DBFFArrSize ); + CallProcErrorHandler ( ERAbort, 0, DERSTL ); + Exit; + End; + Inc ( DBFFArrIdx ); + DBFFPtr := @DBFFArrPtr^ [DBFFArrIdx]; + End; + CurFNPtr := CurFNPtr^.NextPtr; + End; + + If UseMemo Then Begin + If LHPtr^.DBHeaderPtr^.DBVer = DBVersion4X Then Begin + Header.Part.DBaseVer := DB4DataAndMemo; + End Else Begin + Header.Part.DBaseVer := DBDataAndMemo; + End; + End Else Begin + Header.Part.DBaseVer := DBDataOnly; + End; + Header.Part.HeaderSize := 1 + SizeOf ( DBaseFileFullHeader ) + + LHPtr^.DBHeaderPtr^.Fields * SizeOf ( DBaseFileField ); + SetDateOfToDay ( Header.Part.LastChange ); + Move ( Header.Part, LHPtr^.DBHeaderPtr^.Header, + SizeOf ( DBaseFileHeader ) ); + + {--Build empty dBASE data file} + DBFName := IsamForceExtension ( DBFName, DBDataExtension ); + IsamAssign ( LHPtr^.DBHeaderPtr^.IFile, DBFName ); + IsamRewrite ( LHPtr^.DBHeaderPtr^.IFile ); + If Not IsamOK Then Begin + Error := IsamError; + DBaseCreate := BTIsamErrorClass; + UndoDBaseCreate ( @LHPtr^.DBHeaderPtr^.IFile, Nil, DBFFArrPtr, + DBFFArrSize ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + IsamBlockWrite ( LHPtr^.DBHeaderPtr^.IFile, Header, + SizeOf ( DBaseFileFullHeader ) ); + If Not IsamOK Then Begin + Error := IsamError; + DBaseCreate := BTIsamErrorClass; + UndoDBaseCreate ( @LHPtr^.DBHeaderPtr^.IFile, Nil, DBFFArrPtr, + DBFFArrSize ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + IsamBlockWrite ( LHPtr^.DBHeaderPtr^.IFile, DBFFArrPtr^, + DBFFArrSize ); + If Not IsamOK Then Begin + Error := IsamError; + DBaseCreate := BTIsamErrorClass; + UndoDBaseCreate ( @LHPtr^.DBHeaderPtr^.IFile, Nil, DBFFArrPtr, + DBFFArrSize ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + TerminateDBF [0] := DBEndOfHeader; + If LHPtr^.DBHeaderPtr^.DBVer = DBVersion4X Then Begin + TerminateDBF [1] := DBEndOfFile; + IsamBlockWrite ( LHPtr^.DBHeaderPtr^.IFile, TerminateDBF, 2 ); + End Else Begin + IsamBlockWrite ( LHPtr^.DBHeaderPtr^.IFile, TerminateDBF, 1 ); + End; + If Not IsamOK Then Begin + Error := IsamError; + DBaseCreate := BTIsamErrorClass; + UndoDBaseCreate ( @LHPtr^.DBHeaderPtr^.IFile, Nil, DBFFArrPtr, + DBFFArrSize ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + FreeMem ( DBFFArrPtr, DBFFArrSize ); + + {--Build empty dBASE memo file} + If UseMemo Then Begin + If MaxAvail < SizeOf ( DBaseMemo ) Then Begin + UndoDBaseCreate ( @LHPtr^.DBHeaderPtr^.IFile, Nil, Nil, 0 ); + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( LHPtr^.DBHeaderPtr^.MemoPtr, SizeOf ( DBaseMemo ) ); + + DBFName := IsamForceExtension ( DBFName, DBMemoExtension ); + IsamAssign ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, DBFName ); + IsamRewrite ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile ); + If Not IsamOK Then Begin + Error := IsamError; + DBaseCreate := BTIsamErrorClass; + UndoDBaseCreate ( @LHPtr^.DBHeaderPtr^.IFile, Nil, Nil, 0 ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + + FillChar ( LHPtr^.DBHeaderPtr^.MemoPtr^.Header, + SizeOf ( DBaseMemoHeader ), 0 ); + LHPtr^.DBHeaderPtr^.MemoPtr^.Header.NextFree := 1; + If LHPtr^.DBHeaderPtr^.DBVer = DBVersion4X Then Begin + DBFName := StrUpCase ( GetFNameOnly ( DBFName )); {!!.42mod} + Error := LBStr2CArr ( + @LHPtr^.DBHeaderPtr^.MemoPtr^.Header.FileName, + DBFName, Length ( DBFName ) ); + LHPtr^.DBHeaderPtr^.MemoPtr^.Header.Valid := DB4ValidMemoFile; + LHPtr^.DBHeaderPtr^.MemoPtr^.Header.BlockSize := DBMinMemoRecSize; + End; + + IsamBlockWrite ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, + LHPtr^.DBHeaderPtr^.MemoPtr^.Header, + SizeOf ( DBaseMemoHeader ) ); + If Not IsamOK Then Begin + Error := IsamError; + DBaseCreate := BTIsamErrorClass; + UndoDBaseCreate ( @LHPtr^.DBHeaderPtr^.IFile, + @LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, Nil, 0 ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + + {--Initializes header with #0} + DBaseWriteDummyBlock ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, + DBMinMemoRecSize - SizeOf ( DBaseMemoHeader ) ); + If Not IsamOK Then Begin + Error := IsamError; + DBaseCreate := BTIsamErrorClass; + UndoDBaseCreate ( @LHPtr^.DBHeaderPtr^.IFile, + @LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, Nil, 0 ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + End; + LHPtr^.DBHeaderPtr^.RefNr := 1; + Error := DBaseGo ( LHPtr, LHPtr^.DBHeaderPtr^.RefNr ); + DBaseCreate := 0; + End; + + + Function DBaseWriteRecord ( LHPtr : PListHeader; + Var Buf ) : Integer; + + Begin + IsamClearOK; + IsamBlockWrite ( LHPtr^.DBHeaderPtr^.IFile, Buf, + LHPtr^.DBHeaderPtr^.Header.RecordSize ); + If Not IsamOK Then Begin + DBaseWriteRecord := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + Inc ( LHPtr^.DBHeaderPtr^.Header.NrOfRecs ); + LHPtr^.DBHeaderPtr^.Modified := True; + DBaseWriteRecord := 0; + End; + + + Function DBase3WriteMemoRec ( LHPtr : PListHeader; + Var RefNr : Longint; + Var Buf ) : Integer; + + Var + Len, + Blocks : Word; + Size : Longint; + SaveCh : Char; + + Begin + IsamClearOK; + RefNr := LHPtr^.DBHeaderPtr^.MemoPtr^.Header.NextFree; + IsamLongSeek ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, + DBMinMemoRecSize * RefNr ); + If Not IsamOK Then Begin + DBase3WriteMemoRec := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + + Len := GetAZSLength ( @Buf ) + 1; + Blocks := Len Div DBMinMemoRecSize; + If ( Len Mod DBMinMemoRecSize ) <> 0 Then Inc ( Blocks ); + Size := Longint ( Blocks ) * Longint ( DBMinMemoRecSize ); + If Size > Longint ( DBMaxMemoSize ) Then Begin + Size := Longint ( DBMaxMemoSize ); + Blocks := Word ( Size Div DBMaxMemoSize ); + If ( Size Mod DBMinMemoRecSize ) <> 0 Then Inc ( Blocks ); + End; + If Len > Size Then Len := Word ( Size ); + + SaveCh := CharArr ( Buf ) [Len - 1]; + CharArr ( Buf ) [Len - 1] := DBEndOfMemoRec; + + IsamBlockWrite ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, Buf, Len ); + CharArr ( Buf ) [Len - 1] := SaveCh; + If Not IsamOK Then Begin + DBase3WriteMemoRec := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + + {--Fill up with #0} + If Len < Size Then Begin + DBaseWriteDummyBlock ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, + Size - Len ); + If Not IsamOK Then Begin + DBase3WriteMemoRec := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + End; + + Inc ( LHPtr^.DBHeaderPtr^.MemoPtr^.Header.NextFree, Blocks ); + LHPtr^.DBHeaderPtr^.MemoPtr^.Modified := True; + DBase3WriteMemoRec := 0; + End; + + + Function DBase4WriteMemoRec ( LHPtr : PListHeader; + Var RefNr : Longint; + Var Buf ) : Integer; + + Var + Blocks : Word; + Len, + Size : Longint; + FMRec : DBase4FirstMemoRec; + + Begin + IsamClearOK; + RefNr := LHPtr^.DBHeaderPtr^.MemoPtr^.Header.NextFree; + IsamLongSeek ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, + LHPtr^.DBHeaderPtr^.MemoPtr^.Header.BlockSize * RefNr ); + If Not IsamOK Then Begin + DBase4WriteMemoRec := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + + Len := GetAZSLength ( @Buf ) + SizeOf ( FMRec ); + Blocks := + Word ( Len Div LHPtr^.DBHeaderPtr^.MemoPtr^.Header.BlockSize ); + If ( Len Mod LHPtr^.DBHeaderPtr^.MemoPtr^.Header.BlockSize ) <> 0 + Then Inc ( Blocks ); + Size := Longint ( Blocks ) * + Longint ( LHPtr^.DBHeaderPtr^.MemoPtr^.Header.BlockSize ); + If Size > Longint ( DBMaxMemoSize ) Then Begin + Size := Longint ( DBMaxMemoSize ); + Blocks := + Word ( Size Div LHPtr^.DBHeaderPtr^.MemoPtr^.Header.BlockSize ); + If ( Size Mod LHPtr^.DBHeaderPtr^.MemoPtr^.Header.BlockSize ) <> 0 + Then Inc ( Blocks ); + End; + If Len > Size Then Len := Size; + + FMRec.Valid := DB4ValidMemoField; + FMRec.Width := Len; + + IsamBlockWrite ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, FMRec, + SizeOf ( FMRec ) ); + If Not IsamOK Then Begin + DBase4WriteMemoRec := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + + IsamBlockWrite ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, Buf, + Word ( Len ) - SizeOf ( FMRec ) ); + If Not IsamOK Then Begin + DBase4WriteMemoRec := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + + {--Fill up with #0} + If Len < Size Then Begin + DBaseWriteDummyBlock ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, + Size - Len ); + If Not IsamOK Then Begin + DBase4WriteMemoRec := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + End; + + Inc ( LHPtr^.DBHeaderPtr^.MemoPtr^.Header.NextFree, Blocks ); + LHPtr^.DBHeaderPtr^.MemoPtr^.Modified := True; + DBase4WriteMemoRec := 0; + End; + + + Function DBaseWriteMemoRec ( LHPtr : PListHeader; + Var RefNr : Longint; + Var Buf ) : Integer; + + Begin + Case LHPtr^.DBHeaderPtr^.Header.DBaseVer And DB4DataAndMemo Of + DBDataAndMemo : + DBaseWriteMemoRec := DBase3WriteMemoRec ( LHPtr, RefNr, Buf ); + DB4DataAndMemo: + DBaseWriteMemoRec := DBase4WriteMemoRec ( LHPtr, RefNr, Buf ); + Else Begin + CallProcErrorHandler ( ERAbort, 0, DEFCNMF ); + DBaseWriteMemoRec := -1; + End; + End; + End; + + + Function DBaseWriteRecAndMemoRec ( LHPtr : PListHeader; + Var BTBuf, + DBBuf ) : Integer; + + Var + Error : Integer; + CurFNPtr : PFieldNode; + NextFree, + MemoRef : Longint; + + Begin + Case LHPtr^.DBHeaderPtr^.Header.DBaseVer And DB4DataAndMemo Of + DBDataOnly: Begin + {no action} + End; + + DB4DataAndMemo, + DBDataAndMemo : Begin + NextFree := LHPtr^.DBHeaderPtr^.MemoPtr^.Header.NextFree; + CurFNPtr := LHPtr^.ListPtr; + While CurFNPtr <> Nil Do Begin + If CurFNPtr^.DBFieldPtr^.Normal.FType = MemoFType Then Begin + If 0 < GetAZSLength ( @CharArr ( BTBuf ) + [CurFNPtr^.BTFieldPtr^.Offset] ) Then Begin + Error := DBaseWriteMemoRec ( LHPtr, MemoRef, + CharArr ( BTBuf ) [CurFNPtr^.BTFieldPtr^.Offset] ); + If Error <> 0 Then Begin + LHPtr^.DBHeaderPtr^.MemoPtr^.Header.NextFree := NextFree; + DBaseWriteRecAndMemoRec := Error; + Exit; + End; + Error := LongInt2CArr ( @CharArr ( DBBuf ) + [CurFNPtr^.DBFieldPtr^.Normal.Offset], MemoRef, + DBMemoFieldWidth ); + If Error <> 0 Then Begin + LHPtr^.DBHeaderPtr^.MemoPtr^.Header.NextFree := NextFree; + DBaseWriteRecAndMemoRec := Error; + Exit; + End; + End Else Begin + FillChar ( CharArr ( DBBuf ) + [CurFNPtr^.DBFieldPtr^.Normal.Offset], + DBMemoFieldWidth, 32 ); + End; + End; + CurFNPtr := CurFNPtr^.NextPtr; + End; + End; + + Else Begin + DBaseWriteRecAndMemoRec := -1; + Exit; + End; + End; + DBaseWriteRecAndMemoRec := DBaseWriteRecord ( LHPtr, DBBuf ); + End; + + + Function DBaseWriteEOFSign ( LHPtr : PListHeader ) : Integer; + + Const + EOFSign : Char = Chr ( $1A ); + + Var + Position : Longint; + + Begin + DBaseWriteEOFSign := 0; + IsamClearOK; + Position := LHPtr^.DBHeaderPtr^.Header.HeaderSize + + LHPtr^.DBHeaderPtr^.Header.NrOfRecs * + Longint ( LHPtr^.DBHeaderPtr^.Header.RecordSize ); + IsamLongSeek ( LHPtr^.DBHeaderPtr^.IFile, Position ); + If Not IsamOK Then Begin + DBaseWriteEOFSign := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + IsamBlockWrite ( LHPtr^.DBHeaderPtr^.IFile, EOFSign, + SizeOf ( EOFSign ) ); + If Not IsamOK Then Begin + DBaseWriteEOFSign := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + End; + + + Function Isam2DBase ( FNPtr : PFieldNode; + Var SrcBuf, + DstBuf; + ProcCArrConv : VoidFct_CharArrConvert ) + : Integer; + + Begin + Case FNPtr^.BTFieldPtr^.CType Of + ReservedCType : Begin + If FNPtr^.DBFieldPtr^.Normal.FType = DelMarkFType Then Begin + If Longint ( SrcBuf ) = 0 Then Begin + Char ( DstBuf ) := ' '; + End Else Begin + Char ( DstBuf ) := '*'; + End; + Isam2DBase := 0; + End Else Begin + Isam2DBase := -1; + End; + End; + + DateCType : Begin + Isam2DBase := Date2CArr ( @DstBuf, Longint ( SrcBuf ) ); + End; + + TimeCType: Begin + Isam2DBase := Time2CArr ( @DstBuf, Longint ( SrcBuf ) ); + End; + + StringCType : Begin + Isam2DBase := LBStr2CArr ( @DstBuf, String ( SrcBuf ), + FNPtr^.DBFieldPtr^.Normal.Width ); + CallProcCArrConv ( ProcCArrConv, @DstBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + AZStringCType : Begin + If FNPtr^.DBFieldPtr^.Normal.FType = MemoFType Then Begin + FillChar ( DstBuf, DBMemoFieldWidth, Chr ( 32 ) ); + Isam2DBase := 0; + End Else Begin + Isam2DBase := AZStr2CArr ( @DstBuf, @SrcBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + CallProcCArrConv ( ProcCArrConv, @DstBuf, + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + End; + + BooleanCType : Begin + Isam2DBase := Boolean2Char ( Char ( DstBuf ), Boolean ( SrcBuf ) ); + End; + + CharCType : Begin + Char ( DstBuf ) := Char ( SrcBuf ); + CallProcCArrConv ( ProcCArrConv, @DstBuf, 1 ); + Isam2DBase := 0; + End; + + ByteCType : Begin + Isam2DBase := Byte2CArr ( @DstBuf, Byte ( SrcBuf ), + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + ShortIntCType : Begin + Isam2DBase := ShortInt2CArr ( @DstBuf, ShortInt ( SrcBuf ), + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + IntegerCType : Begin + Isam2DBase := Integer2CArr ( @DstBuf, Integer ( SrcBuf ), + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + WordCType : Begin + Isam2DBase := Word2CArr ( @DstBuf, Integer ( SrcBuf ), + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + LongIntCType : Begin + Isam2DBase := LongInt2CArr ( @DstBuf, Longint ( SrcBuf ), + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + { CompCType : Begin } {!!.51} + { Isam2DBase := Comp2CArr ( @DstBuf, Comp ( SrcBuf ), } {!!.51} + { FNPtr^.DBFieldPtr^.Normal.Width ); } {!!.51} + { End; } {!!.51} + + { RealCType : Begin } {!!.51} + { Isam2DBase := Real2CArr ( @DstBuf, Real ( SrcBuf ), } {!!.51} + { FNPtr^.DBFieldPtr^.Normal.Width, } {!!.51} + { FNPtr^.DBFieldPtr^.Normal.Decimals ); } {!!.51} + { End; } {!!.51} + + CompCType : Begin + Isam2DBase := Comp2CArr ( @DstBuf, Comp ( SrcBuf ), + FNPtr^.DBFieldPtr^.Normal.Width ); + End; + + SingleCType: Begin + Isam2DBase := Single2CArr ( @DstBuf, Single ( SrcBuf ), + FNPtr^.DBFieldPtr^.Normal.Width, + FNPtr^.DBFieldPtr^.Normal.Decimals ); + End; + + RealCType : Begin + Isam2DBase := Real2CArr ( @DstBuf, Real ( SrcBuf ), + FNPtr^.DBFieldPtr^.Normal.Width, + FNPtr^.DBFieldPtr^.Normal.Decimals ); + End; + + DoubleCType : Begin + Isam2DBase := Double2CArr ( @DstBuf, Double ( SrcBuf ), + FNPtr^.DBFieldPtr^.Normal.Width, + FNPtr^.DBFieldPtr^.Normal.Decimals ); + End; + + ExtendedCType : Begin + Isam2DBase := Extended2CArr ( @DstBuf, Extended ( SrcBuf ), + FNPtr^.DBFieldPtr^.Normal.Width, + FNPtr^.DBFieldPtr^.Normal.Decimals ); + End; + + Else Begin + Isam2DBase := -1; + End; + End; + End; + + + Function DBaseExport ( LHPtr : PListHeader; + DBFName : DBaseFileName; + KeyNr : Word; + FuncReXUser : IntFct_ReXUser; + ProcCArrConv : VoidFct_CharArrConvert; + FuncDecideWrite : EnumFct_DecideWrite ) + : Integer; + + Var + BTBufPtr, + DBBufPtr : ^Char; + Ref, + IsamRecs, + ReadRecs, + WriteRecs, + ErrorRecs : Longint; + ErrorFields, + Error : Integer; + UserAbort : Boolean; + CurFNPtr : PFieldNode; + TempFName : IsamFileName; + DumpFilePtr : PText; + KeyStr : IsamKeyStr; + + Begin + DBaseExport := -1; + + If Not CheckListHeaderPtr ( LHPtr, False ) Then Begin + CallProcErrorHandler ( ERAbort, 0, DELHNI ); + Exit; + End; + + Error := DBaseCreate ( LHPtr, DBFName ); + If Error <> 0 Then Begin + DBaseExport := Error; + Exit; + End; + + If MaxAvail < LHPtr^.BTHeaderPtr^.DatSLen Then Begin + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( BTBufPtr, LHPtr^.BTHeaderPtr^.DatSLen ); + + If MaxAvail < LHPtr^.DBHeaderPtr^.Header.RecordSize Then Begin + UndoDBaseImpExp ( LHPtr, BTBufPtr, Nil, + LHPtr^.BTHeaderPtr^.DatSLen, 0 ); + CallProcErrorHandler ( ERAbort, 0, DEOOM ); + Exit; + End; + GetMem ( DBBufPtr, LHPtr^.DBHeaderPtr^.Header.RecordSize ); + + IsamRecs := BTUsedRecs ( LHPtr^.BTHeaderPtr^.FBPtr ); + If Not IsamOK Then Begin + Error := IsamError; + DBaseExport := BTIsamErrorClass; + UndoDBaseImpExp ( LHPtr, BTBufPtr, DBBufPtr, + LHPtr^.BTHeaderPtr^.DatSLen, + LHPtr^.DBHeaderPtr^.Header.RecordSize ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + Inc ( IsamRecs, BTFreeRecs ( LHPtr^.BTHeaderPtr^.FBPtr ) ); + If Not IsamOK Then Begin + Error := IsamError; + DBaseExport := BTIsamErrorClass; + UndoDBaseImpExp ( LHPtr, BTBufPtr, DBBufPtr, + LHPtr^.BTHeaderPtr^.DatSLen, + LHPtr^.DBHeaderPtr^.Header.RecordSize ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + + UserAbort := CallFuncReXUser ( FuncReXUser, WSInit, LHPtr, + IsamRecs, LHPtr^.BTHeaderPtr^.DatSLen, 0, DBBufPtr^ ) <> 0; + + If KeyNr <> 0 Then Begin + KeyStr := ''; + BTSearchKey ( LHPtr^.BTHeaderPtr^.FBPtr, KeyNr, Ref, KeyStr ); + If Not IsamOK Then Begin + Error := IsamError; + DBaseExport := BTIsamErrorClass; + UndoDBaseImpExp ( LHPtr, BTBufPtr, DBBufPtr, + LHPtr^.BTHeaderPtr^.DatSLen, + LHPtr^.DBHeaderPtr^.Header.RecordSize ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + End Else Begin + Ref := 1; + End; + + DumpFilePtr := Nil; + ReadRecs := 0; + WriteRecs := 0; + ErrorRecs := 0; + While IsamOK And ( Not UserAbort ) And + ( ReadRecs < IsamRecs ) Do Begin + BTGetRec ( LHPtr^.BTHeaderPtr^.FBPtr, Ref, BTBufPtr^, + False ); + If IsamOK Then Begin + FillChar ( DBBufPtr^, LHPtr^.DBHeaderPtr^.Header.RecordSize, ' ' ); + ErrorFields := 0; + CurFNPtr := LHPtr^.ListPtr; + While CurFNPtr <> Nil Do Begin + CurFNPtr^.ConvStatus := Isam2DBase ( CurFNPtr, + PCharArr ( BTBufPtr )^ [CurFNPtr^.BTFieldPtr^.Offset], + PCharArr ( DBBufPtr )^ [CurFNPtr^.DBFieldPtr^.Normal.Offset], + ProcCArrConv ); + If CurFNPtr^.ConvStatus <> 0 Then Begin + Inc ( ErrorFields ); + CallProcErrorHandler ( ERIgnore, 0, DEECF ); + End; + CurFNPtr := CurFNPtr^.NextPtr; + End; + + If ErrorFields <> 0 Then Begin + Error := WriteDump ( DumpFilePtr, LHPtr, ErrorFields ); + Inc ( ErrorRecs ); + End; + + Case CallFuncDecideWrite ( FuncDecideWrite, LHPtr, ErrorFields, + BTBufPtr^, DBBufPtr^ ) Of + DCWrite : Begin + Error := DBaseWriteRecAndMemoRec ( LHPtr, BTBufPtr^, + DBBufPtr^ ); + If Error <> 0 Then Begin + UndoDBaseImpExp ( LHPtr, BTBufPtr, DBBufPtr, + LHPtr^.BTHeaderPtr^.DatSLen, + LHPtr^.DBHeaderPtr^.Header.RecordSize ); + DBaseExport := Error; + End; + Inc ( WriteRecs ); + Error := DBaseSkip ( LHPtr ); {!!.42} + If Error <> 0 Then Begin {!!.42} + UndoDBaseImpExp ( LHPtr, BTBufPtr, DBBufPtr, {!!.42} + LHPtr^.BTHeaderPtr^.DatSLen, {!!.42} + LHPtr^.DBHeaderPtr^.Header.RecordSize ); {!!.42} + DBaseExport := Error; {!!.42} + Exit; {!!.42} + End; {!!.42} + End; + + DCSkip : ; + + DCAbort : Exit; + + Else Begin + CallProcErrorHandler ( ERIgnore, 0, DEPE ); + Exit; + End; + End; + + Inc ( ReadRecs ); + UserAbort := CallFuncReXUser ( FuncReXUser, WSWork, LHPtr, + ReadRecs, WriteRecs, ErrorRecs, DBBufPtr^ ) <> 0; + + If KeyNr <> 0 Then Begin + BTNextKey ( LHPtr^.BTHeaderPtr^.FBPtr, KeyNr, Ref, KeyStr ); + If (Not IsamOK) And (IsamError <> 10250) Then Begin + Error := IsamError; + DBaseExport := BTIsamErrorClass; + UndoDBaseImpExp ( LHPtr, BTBufPtr, DBBufPtr, + LHPtr^.BTHeaderPtr^.DatSLen, + LHPtr^.DBHeaderPtr^.Header.RecordSize ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + End Else Begin + Ref := ReadRecs + 1; + End; + End; + End; + + If (Not IsamOK) And (IsamError <> 10250) Then Begin + Error := IsamError; + DBaseExport := BTIsamErrorClass; + UndoDBaseImpExp ( LHPtr, BTBufPtr, DBBufPtr, + LHPtr^.BTHeaderPtr^.DatSLen, + LHPtr^.DBHeaderPtr^.Header.RecordSize ); + CallProcErrorHandler ( ERAbort, Error, DEZERO ); + Exit; + End; + + Error := DBaseWriteEOFSign ( LHPtr ); + If Error <> 0 Then Begin + DBaseExport := Error; + UndoDBaseImpExp ( LHPtr, BTBufPtr, DBBufPtr, + LHPtr^.BTHeaderPtr^.DatSLen, + LHPtr^.DBHeaderPtr^.Header.RecordSize ); + Exit; + End; + + UserAbort := CallFuncReXUser ( FuncReXUser, WSExit, LHPtr, ReadRecs, + WriteRecs, ErrorRecs, DBBufPtr^ ) <> 0; + + FreeMem ( DBBufPtr, LHPtr^.DBHeaderPtr^.Header.RecordSize ); + FreeMem ( BTBufPtr, LHPtr^.BTHeaderPtr^.DatSLen ); + + Error := CloseDumpFile ( DumpFilePtr ); + + DBaseExport := CloseDBaseFiles ( LHPtr ); + End; diff --git a/src/wc_sdk/EMSHEAP.CFG b/src/wc_sdk/EMSHEAP.CFG new file mode 100644 index 0000000..25a5355 --- /dev/null +++ b/src/wc_sdk/EMSHEAP.CFG @@ -0,0 +1,40 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +Const + HandlesToUseForAlloc = 8; + {-Range 1..252, change carefully! + Two additional handles are used internally} + + MinEMSHeapPages = HandlesToUseForAlloc; + {-Range HandlesToUseForAlloc..2048} + + MaxEMSHeapPages = 2048; + {-Range MinEMSHeapPages..2048} + + ToLetFreePages = 1; {!!.42} + {-Range 0..(number of free pages) - 4 - MinEMSHeapPages} diff --git a/src/wc_sdk/FILER.CFG b/src/wc_sdk/FILER.CFG new file mode 100644 index 0000000..2a7fc5e --- /dev/null +++ b/src/wc_sdk/FILER.CFG @@ -0,0 +1,92 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +Const + MaxNrOfKeys = 100; + {-Maximum used number of keys per data record, ranges from 1 to 254} + + MaxKeyLen = 35; + {-Maximum length of a key string} + {-Note: using the Filer DLL this has a upper maximum of 127} + +{$IFNDEF UseFilerDLL} + CreatePageSize = 62; {!!.42} + {-Maximum number of index entries per page used when fileblock + is created} + + MaxPageSize = 62; {!!.42} + {-Maximum number of index entries per page B-Tree Isam can handle; + never set smaller than CreatePageSize!} + + MaxHeight = 8; + {-Maximum height of the tree} + + MaxNrOfWorkStations : Word = 50; + {-Maximum number of work stations in a net, ranges from 1 to 65534} + + DatExtension : String [3] = 'DAT'; + IxExtension : String [3] = 'IX'; + DiaExtension : String [3] = 'DIA'; + SavExtension : String [3] = 'SAV'; + MsgExtension : String [3] = 'MSG'; + {-Extensions for data, index, dialog, save, and message file} + + IsamFBLockTimeOutFactor : Word = 4; + {-A fileblock lock attempt has a timeout of + IsamLockTimeOut * IsamFBLockTimeOutFactor milliseconds} + + IsamLockTimeOut : Word = 768; + {-Maximum time in milliseconds for a lock attempt; + a call to BTLockFileBlock can delay for up to + IsamFBLockTimeOutFactor times this value} + + IsamDelayBetwLocks : Word = 64; + {-Delay time in milliseconds between a failed lock attempt and the + next trial in an MsNet environment} + + SearchForSequentialDefault : Boolean = True; + {-Default value for sequential search mode} + + IsamFlushDOS33 : Boolean = True; + {-Allows usage of DOS version 3.3 flush function $68} + + AddNullKeys : Boolean = True; + {-Setting it to False suppresses adding an empty key while rebuilding + or reorganizing a fileblock} + + TestNetExistance : Boolean = True; {!!.41} + {-Setting it to False suppresses testing the existance of the net in + BTInitIsam} + + InheritFileHandles = False; {!!.41} + {-False suppresses inheriting the file handles used for fileblocks + to child processes} + + DefeatLocalCache : Boolean = False; {!!.53} + {-True executes extra code to defeat local operating system caches + for remote fileblock data, also makes apps slower} +{$ENDIF} diff --git a/src/wc_sdk/FILER.MAK b/src/wc_sdk/FILER.MAK new file mode 100644 index 0000000..4409b3c --- /dev/null +++ b/src/wc_sdk/FILER.MAK @@ -0,0 +1,989 @@ +#********************************************************************* +#* FILER.MAK - MAKE file to rebuild B-Tree Filer * +#********************************************************************* + +#* ***** BEGIN LICENSE BLOCK ***** +#* Version: MPL 1.1 +#* +#* The contents of this file are subject to the Mozilla Public License Version +#* 1.1 (the "License"); you may not use this file except in compliance with +#* the License. You may obtain a copy of the License at +#* http://www.mozilla.org/MPL/ +#* +#* Software distributed under the License is distributed on an "AS IS" basis, +#* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License +#* for the specific language governing rights and limitations under the +#* License. +#* +#* The Original Code is TurboPower B-Tree Filer +#* +#* The Initial Developer of the Original Code is +#* TurboPower Software +#* +#* Portions created by the Initial Developer are Copyright (C) 1996-2002 +#* the Initial Developer. All Rights Reserved. +#* +#* Based in part on code written by Ralf Nagel +#* +#* Contributor(s): +#* +#* ***** END LICENSE BLOCK ***** *) + +# Notes: +# +# 1. This make file is designed to be used only with Borland's MAKE +# utility, version 3.6 and above (ie, it will work with the MAKE.EXE +# supplied with TP7, BP7, or Delphi 1.0, 2.0 and 3.0). +# +# 2. To use this MAKE file go to the \FILER diectory and type in a +# command of the form +# +# MAKE -fFILER.MAK compiler= options= +# +# at the DOS prompt (MAKE is assumed to be on the path). can +# be one of the following (case is sensitive) and must be supplied +# (there is no default): +# +# BP7R - real-mode BP7 +# BP7P - protected-mode BP7 +# BP7W - Windows-mode BP7 +# D1 - Delphi 1 +# D2 - Delphi 2 +# D3 - Delphi 3 +# D4 - Delphi 4 +# D5 - Delphi 5 +# +# can be one of the following, and if it not supplied the +# default value is shown (note that it is only required if the +# compiler value is BP7R or BP7P): +# +# NONE (neither Turbo or Object Professional present *DEFAULT*) +# OPRO (Object Professional present) +# TPRO (Turbo Professional present) +# BOTH (both Turbo or Object Professional present) +# +# A couple of examples: +# +# MAKE -fFILER.MAK Compiler=D1 +# +# will compile B-Tree Filer for use with Delphi 1. +# +# MAKE -fFILER.MAK Compiler=BP7R Options=OPRO +# +# will compile B-Tree Filer for use with BP7 real mode, using Object +# Professional. +# +# 3. The compilers, assembler and Windows resource compilers used by +# this MAKE file are assumed to be on the DOS path. If they are not, +# you will have to supply the full path to the compiler by altering +# the relevant macro below (look for the heading "Compiler Path +# Macros"). +# +# 4. If you do not have a copy of Turbo Assembler, be sure to comment +# out the HaveAssembler macro below. (To comment out a macro, insert +# a # character at the front of the line.) +# +# 5. If BP7R or BP7P is selected, the Turbo Vision parts of B-Tree +# Filer are always compiled. If you do not have TV, or don't want this +# behavior comment out the WantTV macro below. +# +# 6. If you want the B-Tree Filer units compiled with debug +# information, uncomment out the DEBUG macro below. +# +# 7. The directory structure assumed by this MAKE file is +# +# FILER +# +---DEMOS +# +# If you have a different directory structure, then alter the DirBase +# and DirDemos macros below. + + +#---------------------------------------------- Define Assembler Stuff +# Comment this line out if you do not have an assembler. If this macro +# is active, ASM files will be assembled into OBJ files if needed. +#HaveAssembler=1 + + +#------------------------------------------- Define Turbo Vision Stuff +# Comment this line out if you do not want to compile the Turbo Vision +# parts of B-Tree Filer. +WantTV=1 + + +#------------------------------------------- Define Turbo Vision Stuff +# Comment this line out if you do not want to compile the B-Tree Filer +# units with debug information. +# DEBUG=1 + + +#------------------------------------------ Define Directory Structure +# This set of macros define the directory structure for B-Tree Filer's +# source code files and demo programs. +DirBase=\FILER # this *must* be the default directory +DirDemos=$(DirBase)\DEMOS + +#------------------------------------------------ Compiler Path Macros +# These macros define the filenames of the command line compilers, +# assembler and resource compilers. +BP7Compiler=c:\bp7\bin\bpc.exe +Delphi1Compiler=c:\Delphi\bin\dcc.exe +Delphi2Compiler=c:\Delphi2\bin\dcc32.exe +Delphi3Compiler=c:\Delphi3\bin\dcc32.exe +Delphi4Compiler=c:\Delphi4\bin\dcc32.exe +Delphi5Compiler=c:\Delphi5\bin\dcc32.exe +TasmAssembler=c:\TASM\bin\tasm.exe +R16Compiler=c:\Delphi\bin\brcc.exe +R32Compiler=c:\Delphi2\bin\brcc32.exe + +# This macro shows the directories where your OPro and/or TPro units +# are found. The format of the macro's value follows the DOS PATH +# format, for example if you have the OPro units in C:\OPRO and the +# TPro units in C:\TPRO, specify the following: +# +# DirOproTPro=C:\OPRO;C:\TPRO +# +# If you have neither OPro or TPro then leave the macro undefined (ie, +# don't put anything after the equals sign). +DirOProTPro=C:\OPRO;C:\TPRO + + +#------------------------------- Other factors that affect compilation +# +# Note that you must edit BTDEFINE.INC to specify a network option +# and other conditional defines that affect B-Tree Filer + +###################################################################### +# From this point there are no more defines that need to be reviewed # +# or changed. # +###################################################################### + +# if the "compiler" macro is undefined show error +!if !$d(compiler) +!error You must invoke MAKE with compiler= parameter +!endif + +# if the "compiler" macro is invalid show error +!undef PrimTest +!if $(compiler) == BP7R +PrimTest=1 +!elif $(compiler) == BP7P +PrimTest=1 +!elif $(compiler) == BP7W +PrimTest=1 +!elif $(compiler) == D1 +PrimTest=1 +!elif $(compiler) == D2 +PrimTest=1 +!elif $(compiler) == D3 +PrimTest=1 +!elif $(compiler) == D4 +PrimTest=1 +!elif $(compiler) == D5 +PrimTest=1 +!endif +!if !$d(PrimTest) +!error The compiler value is invalid (use BP7R, BP7P, BP7W, D1, D2, D3, D4, D5) +!endif + +# make sure the "options" macro is valid +!undef HaveTPro +!undef HaveOPro +!undef HaveBoth +!if $(compiler) == BP7W +!undef options +!undef WantTV +!elif $(compiler) == D1 +!undef options +!undef WantTV +!elif $(compiler) == D2 +!undef options +!undef WantTV +!elif $(compiler) == D3 +!undef options +!undef WantTV +!elif $(compiler) == D4 +!undef options +!undef WantTV +!elif $(compiler) == D5 +!undef options +!undef WantTV +!endif +!if !$d(options) +options=NONE +!else +!undef PrimTest +!if $(options) == NONE +PrimTest=1 +!elif $(options) == OPRO +PrimTest=1 +HaveOPro=1 +!elif $(options) == TPRO +PrimTest=1 +HaveTPro=1 +!elif $(options) == BOTH +PrimTest=1 +HaveOPro=1 +HaveTPro=1 +HaveBoth=1 +!endif +!if !$d(PrimTest) +options=NONE +!endif +!endif + +# set up the debug directives for the compiles +!if $d(DEBUG) +!if $(__MAKE__)>=0x0370 +DBGDirs=-$$D+ -$$L+ -V +!else +DBGDirs=-$D+ -$L+ -V +!endif +!else +!if $(__MAKE__)>=0x0370 +DBGDirs=-$$D- -$$L- +!else +DBGDirs=-$D- -$L- +!endif +!endif + +# set up the unit extensions; create the compile macro +!if $(compiler) == BP7R +uext=TPU +Compile=$(BP7Compiler) -CD $(DBGDirs) /L +!elif $(compiler) == BP7P +uext=TPP +Compile=$(BP7Compiler) -CP $(DBGDirs) /L +!elif $(compiler) == BP7W +uext=TPW +Compile=$(BP7Compiler) -CW $(DBGDirs) /L +!elif $(compiler) == D1 +uext=DCU +Compile=$(Delphi1Compiler) $(DBGDirs) /L +!elif $(compiler) == D2 +uext=DCU +Compile=$(Delphi2Compiler) $(DBGDirs) /L +!elif $(compiler) == D3 +uext=DCU +Compile=$(Delphi3Compiler) $(DBGDirs) /L +!elif $(compiler) == D4 +uext=DCU +Compile=$(Delphi4Compiler) $(DBGDirs) /L +!elif $(compiler) == D5 +uext=DCU +Compile=$(Delphi5Compiler) $(DBGDirs) /L -LE$(DirBase) -LN$(DirBase) +!endif + +# create a couple of handy macros +!undef RMode +!undef PMode +!undef DOSMode +!undef WinMode +!undef Win32Mode +!undef DelphiMode +!if $(compiler) == BP7R +RMode=1 +DOSMode=1 +!elif $(compiler) == BP7P +PMode=1 +DOSMode=1 +!elif $(compiler) == BP7W +PMode=1 +WinMode=1 +!elif $(compiler) == D1 +PMode=1 +WinMode=1 +DelphiMode=1 +!elif $(compiler) == D2 +Win32Mode=1 +DelphiMode=1 +!elif $(compiler) == D3 +Win32Mode=1 +DelphiMode=1 +!elif $(compiler) == D4 +Win32Mode=1 +DelphiMode=1 +!elif $(compiler) == D5 +Win32Mode=1 +DelphiMode=1 +!endif + +# create a few macros to aid with presence/absence of OPro, TPro, TV +NeedOProFiles= +NeedTProFiles= +NeedTVFiles= +!if $d(HaveOPro) +NeedOProFiles=OProFiles +!endif +!if $d(HaveTPro) +NeedTProFiles=TProFiles +!endif +!if $d(WantTV) +NeedTVFiles=TVFiles +!endif + + +#---------------------------------Force all units/demos to be compiled +!if $(compiler) == BP7R +dummy: NonWin32Files RModeFiles DOSFiles \ + $(NeedOProFiles) $(NeedTProFiles) $(NeedTVFiles) \ + NWFiles CommonFiles +!elif $(compiler) == BP7P +dummy: NonWin32Files PModeFiles DOSFiles \ + $(NeedOProFiles) $(NeedTProFiles) $(NeedTVFiles) \ + NWFiles CommonFiles +!elif $(compiler) == BP7W +dummy: WBrowser.$(uext) \ + $(DirDemos)\BTWDEMO.EXE \ + $(DirDemos)\OWDemo.EXE \ + NonWin32Files PModeFiles NWFiles CommonFiles +!elif $(compiler) == D1 +dummy: DOSSupp.DCU FVCBrows.R16 FVCReg.$(uext) \ + NonWin32Files PModeFiles NWFiles DelphiFiles CommonFiles +!elif $(compiler) == D2 +dummy: FVCBrows.R32 FVCReg.$(uext) \ + Win32Files DelphiFiles CommonFiles +!elif $(compiler) == D3 +dummy: FVCBrows.R32 \ + T555_R30.DPL T555_D30.DPL \ + Win32Files DelphiFiles CommonFiles +!elif $(compiler) == D4 +dummy: FVCBrows.R32 \ + T555_R40.DPL T555_D40.DPL \ + Win32Files DelphiFiles CommonFiles +!elif $(compiler) == D5 +dummy: FVCBrows.R32 \ + T555_R50.DPL T555_D50.DPL \ + Win32Files DelphiFiles CommonFiles +!endif + +RModeFiles : EMSSupp.$(uext) EMSHeap.$(uext) \ + TPAlloc.$(uext) MSort.$(uext) \ + $(DirDemos)\BigSort.EXE + +PModeFiles : DPMI.$(uext) MSortP.$(uext) + +DOSFiles : TPCmd.$(uext) Browser.$(uext) \ + $(DirDemos)\DB2Isam.EXE $(DirDemos)\Isam2DB.EXE \ + $(DirDemos)\SimpDemo.EXE + +OProFiles : OPBrow.$(uext) \ + $(DirDemos)\OPISDEMO.EXE + +TProFiles : $(DirDemos)\NETDEMO.EXE + +TVFiles : TVBrows.$(uext) \ + $(DirDemos)\TVISDEMO.EXE + +NonWin32Files : NumKeys.OBJ NumKeys.$(uext) NetBIOS.$(uext) \ + CarrConv.$(uext) DBImpExp.$(uext) \ + $(DirDemos)\BindList.EXE $(DirDemos)\MesExamp.EXE \ + $(DirDemos)\NBChat.EXE $(DirDemos)\NBSend.EXE \ + $(DirDemos)\NETINFO.EXE $(DirDemos)\NISEND.EXE \ + $(DirDemos)\NSSEND.EXE $(DirDemos)\SPX2WAY.EXE \ + $(DirDemos)\TTSFILER.EXE + +Win32Files : NumKey32.$(uext) + +DelphiFiles : FVCBrows.$(uext) \ + $(DirDemos)\DelDemo.EXE + +NWFiles : NWBase.$(uext) NWBind.$(uext) NWConn.$(uext) \ + NWFile.$(uext) NWIPXSPX.$(uext) NWMsg.$(uext) \ + NWPrint.$(uext) NWSema.$(uext) NWTTS.$(uext) \ + OOPSema.$(uext) Share.$(uext) + +CommonFiles : BTDEFINE.INC \ + BTBase.$(uext) BTFileIO.$(uext) BTIsBase.$(uext) \ + Filer.$(uext) VRec.$(uext) Restruct.$(uext) \ + Reindex.$(uext) Rebuild.$(uext) VRebuild.$(uext) \ + Reorg.$(uext) VReorg.$(uext) FixToVar.$(uext) \ + IsamTool.$(uext) \ + LowBrows.$(uext) MedBrows.$(uext) HiBrows.$(uext) \ + $(DirDemos)\Traffic.EXE + +#-------------------------------------------- Assembly Language Source + +!if $d(HaveAssembler) +!if !$d(Win32Mode) +NumKeys.OBJ: NumKeys.ASM + $(TasmAssembler) $*; +!endif +!endif + + +#--------------------------------------------------------------- Units + +# DOSSupp, Delphi 1 only +!if $(compiler) == D1 +DOSSupp.$(uext): BTDEFINE.INC DOSSupp.PAS + $(Compile) $& +!endif + +# BaseSupp, not Delphi 2 or 3 +!if !$d(Win32Mode) +!if $(compiler) == D1 +BaseSupp.$(uext): BTDEFINE.INC BaseSupp.PAS DOSSupp.$(uext) + $(Compile) $& +!else +BaseSupp.$(uext): BTDEFINE.INC BaseSupp.PAS + $(Compile) $& +!endif +!endif + +# EMSSupp, BP7 real mode only +!if $d(RMode) +EMSSupp.$(uext): BTDEFINE.INC EMSSupp.PAS \ + BaseSupp.$(uext) + $(Compile) $& +!endif + +# EMSHeap, BP7 real mode only +!if $d(RMode) +EMSHeap.$(uext): BTDEFINE.INC EMSHeap.PAS EMSHeap.CFG \ + EMSSupp.$(uext) + $(Compile) $& +!endif + +# BTBase, all +BTBase.$(uext): BTDEFINE.INC BTBase.PAS + $(Compile) $& + +# BTFileIO, all +BTFileIO.$(uext): BTDEFINE.INC BTFileIO.PAS BTBase.$(uext) + $(Compile) $& + +# BTIsBase, all +!if !$d(Win32Mode) +BTIsBase.$(uext): BTDEFINE.INC BTIsBase.PAS \ + FILER.CFG ISNETSUP.INC BTLCKMGR.INC \ + BaseSupp.$(uext) \ + BTBase.$(uext) BTFileIO.$(uext) + $(Compile) $& +!else +BTIsBase.$(uext): BTDEFINE.INC BTIsBase.PAS \ + FILER.CFG ISNETSUP.INC BTLCKMGR.INC \ + BTBase.$(uext) BTFileIO.$(uext) + $(Compile) $& +!endif + +# DPMI, not Delphi 2 or 3 +!if !$d(Win32Mode) +DPMI.$(uext): DPMI.PAS + $(Compile) $& +!endif + +# NWBase, not Delphi 2 or 3 +!if !$d(Win32Mode) +!if $(compiler) == D1 +NWBase.$(uext): BTDEFINE.INC NWBase.PAS \ + DPMI.$(uext) DOSSupp.$(uext) + $(Compile) $& +!else +NWBase.$(uext): BTDEFINE.INC NWBase.PAS \ + DPMI.$(uext) + $(Compile) $& +!endif +!endif + +# NWBind, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWBind.$(uext): BTDEFINE.INC NWBind.PAS \ + NWBase.$(uext) + $(Compile) $& +!endif + +# NWConn, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWConn.$(uext): BTDEFINE.INC NWConn.PAS \ + NWBase.$(uext) NWBind.$(uext) + $(Compile) $& +!endif + +# NWFile, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWFile.$(uext): BTDEFINE.INC NWFile.PAS \ + NWBase.$(uext) NWConn.$(uext) + $(Compile) $& +!endif + +# NWIPXSPX, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWIPXSPX.$(uext): BTDEFINE.INC NWIPXSPX.PAS \ + NWBase.$(uext) + $(Compile) $& +!endif + +# NWMsg, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWMsg.$(uext): BTDEFINE.INC NWMsg.PAS \ + NWBase.$(uext) NWConn.$(uext) + $(Compile) $& +!endif + +# NWPrint, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWPrint.$(uext): BTDEFINE.INC NWPrint.PAS \ + NWBase.$(uext) NWBind.$(uext) NWConn.$(uext) \ + NWFile.$(uext) + + $(Compile) $& +!endif + +# NWSema, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWSema.$(uext): BTDEFINE.INC NWSema.PAS \ + NWBase.$(uext) NWConn.$(uext) + $(Compile) $& +!endif + +# NWTTS, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWTTS.$(uext): BTDEFINE.INC NWTTS.PAS \ + NWBase.$(uext) + $(Compile) $& +!endif + +# OOPSema, not Delphi 2 or 3 +!if !$d(Win32Mode) +OOPSema.$(uext): BTDEFINE.INC OOPSema.PAS \ + NWBase.$(uext) NWSema.$(uext) + $(Compile) $& +!endif + +# Share, not Delphi 2 or 3 +!if !$d(Win32Mode) +!if $(compiler) == D1 +Share.$(uext): BTDEFINE.INC Share.PAS \ + DPMI.$(uext) DOSSupp.$(uext) + $(Compile) $& +!else +Share.$(uext): BTDEFINE.INC Share.PAS \ + DPMI.$(uext) + $(Compile) $& +!endif +!endif + +# NetBIOS, not Delphi 2 or 3 +!if !$d(Win32Mode) +!if $(compiler) == D1 +NetBIOS.$(uext): BTDEFINE.INC NetBIOS.PAS \ + DPMI.$(uext) DOSSupp.$(uext) + $(Compile) $& +!else +NetBIOS.$(uext): BTDEFINE.INC NetBIOS.PAS \ + DPMI.$(uext) + $(Compile) $& +!endif +!endif + +# Filer, all +!if $d(Win32Mode) +Filer.$(uext): BTDEFINE.INC FILER.PAS \ + FILER.INC ISAMBASE.INC ISAMLOW.INC ISAMWORK.INC \ + ISAMNWRK.INC \ + BTBase.$(uext) BTIsBase.$(uext) + $(Compile) $& +!else +!if $d(RMode) +Filer.$(uext): BTDEFINE.INC Filer.PAS \ + Filer.INC IsamBase.INC IsamLow.INC IsamWork.INC \ + IsamNWrk.INC \ + EMSSupp.$(uext) EMSHeap.$(uext) \ + BaseSupp.$(uext) BTBase.$(uext) BTIsBase.$(uext) + $(Compile) $& +!else +Filer.$(uext): BTDEFINE.INC Filer.PAS \ + Filer.INC IsamBase.INC IsamLow.INC IsamWork.INC \ + IsamNWrk.INC \ + BaseSupp.$(uext) BTBase.$(uext) BTIsBase.$(uext) + $(Compile) $& +!endif +!endif + +# VRec, all +VRec.$(uext): BTDEFINE.INC VRec.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) + $(Compile) $& + +# NumKeys, not Delphi 2 or 3 +!if !$d(Win32Mode) +NumKeys.$(uext): BTDEFINE.INC NumKeys.PAS \ + NumKeys.OBJ + $(Compile) $& +!endif + +# NumKey32, Delphi 2 or 3 only +!if $d(Win32Mode) +NumKey32.$(uext): BTDEFINE.INC NumKey32.PAS + $(Compile) $& +!endif + +# BufRecIO, all +BufRecIO.$(uext): BTDEFINE.INC BufRecIO.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + VRec.$(uext) + $(Compile) $& + +# Restruct, all +Restruct.$(uext): BTDEFINE.INC Restruct.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + VRec.$(uext) BufRecIO.$(uext) + $(Compile) $& + +# ReIndex, all +Reindex.$(uext): BTDEFINE.INC Reindex.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + VRec.$(uext) BufRecIO.$(uext) + $(Compile) $& + +# Rebuild, all +Rebuild.$(uext): BTDEFINE.INC Rebuild.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Restruct.$(uext) Reindex.$(uext) + $(Compile) $& + +# VRebuild, all +VRebuild.$(uext): BTDEFINE.INC VRebuild.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Vrec.$(uext) Restruct.$(uext) Reindex.$(uext) + $(Compile) $& + +# Reorg, all +Reorg.$(uext): BTDEFINE.INC Reorg.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Restruct.$(uext) Reindex.$(uext) + $(Compile) $& + +# VReorg, all +VReorg.$(uext): BTDEFINE.INC VReorg.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Vrec.$(uext) Restruct.$(uext) Reindex.$(uext) + $(Compile) $& + +# FixToVar, all +FixToVar.$(uext): BTDEFINE.INC FixToVar.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Restruct.$(uext) Reindex.$(uext) VReorg.$(uext) + $(Compile) $& + +# IsamTool, all +IsamTool.$(uext): BTDEFINE.INC IsamTool.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) + $(Compile) $& + +# TPAlloc, BP7 real mode +!if $d(RMode) +TPAlloc.$(uext): BTDEFINE.INC TPAlloc.PAS + $(Compile) $& +!endif + +# MSort, BP7 real mode +!if $d(RMode) +MSort.$(uext): BTDEFINE.INC MSort.PAS \ + MSortEMS.INC MSortINF.INC \ + EMSSupp.$(uext) + $(Compile) $& +!endif + +# MSortP, protected mode only +!if $d(PMode) +MSortP.$(uext): BTDEFINE.INC MSortP.PAS + $(Compile) $& +!endif + +# CarrConv, not Delphi 2 or 3 +!if !$d(Win32Mode) +CarrConv.$(uext): BTDEFINE.INC CarrConv.PAS + $(Compile) $& +!endif + +# DBImpExp, not Delphi 2 or 3 +!if !$d(Win32Mode) +DBImpExp.$(uext): BTDEFINE.INC DBImpExp.PAS \ + DBImpExp.IN1 DBImpExp.IN2 \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + CarrConv.$(uext) + $(Compile) $& +!endif + +# TPCmd, BP7R and BP7P only +!if $d(DOSMode) +TPCmd.$(uext): BTDEFINE.INC TPDEFINE.INC TPCmd.PAS + $(Compile) $& +!endif + +# Browser, BP7R and BP7P only +!if $d(DOSMode) +Browser.$(uext): BTDEFINE.INC TPDEFINE.INC Browser.PAS \ + Browser.INC \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Vrec.$(uext) TPCmd.$(uext) + $(Compile) $& /m -o$(DirOProTPro) -u$(DirOProTPro) -i$(DirOProTPro) +!endif + +# LowBrows, all +LowBrows.$(uext): BTDEFINE.INC BRDefOpt.INC LowBrows.PAS \ + BRLISAM.INC \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Vrec.$(uext) + $(Compile) $& + +# MedBrows, all +MedBrows.$(uext): BTDEFINE.INC BRDefOpt.INC MedBrows.PAS \ + LowBrows.$(uext) + $(Compile) $& + +# HiBrows, all +HiBrows.$(uext): BTDEFINE.INC BRDefOpt.INC HiBrows.PAS \ + LowBrows.$(uext) MedBrows.$(uext) + $(Compile) $& + +# OPBrow, DOS mode only +!if $d(DOSMode) +OPBrow.$(uext): BTDEFINE.INC BRDefOpt.INC OPBrow.PAS \ + OPBrow.ICD \ + DPMI.$(uext) \ + Filer.$(uext) LowBrows.$(uext) MedBrows.$(uext) \ + HiBrows.$(uext) + $(Compile) $& /m -i$(DirOProTPro) -o$(DirOProTPro) -u$(DirOProTPro) +!endif + +# TVBrows, DOS mode only with WantTV +!if $d(DOSMode) +!if $d(WantTV) +TVBrows.$(uext): BTDEFINE.INC BRDefOpt.INC TVBrows.PAS \ + Filer.$(uext) LowBrows.$(uext) MedBrows.$(uext) \ + HiBrows.$(uext) + $(Compile) $& +!endif +!endif + +# WBrowser, BP7W mode only +!if $(compiler) == BP7W +WBrowser.$(uext): BTDEFINE.INC BRDefOpt.INC WBrowser.PAS \ + Filer.$(uext) LowBrows.$(uext) MedBrows.$(uext) \ + HiBrows.$(uext) + $(Compile) $& +!endif + +# FVCBrows.R16, Delphi 1 only +!if $(compiler) == D1 +FVCBrows.R16: FVCBrows.RC + $(R16Compiler) -fo$&.R16 $& +!endif + +# FVCBrows.R32, Delphi 2 and 3 only +!if $d(Win32Mode) +FVCBrows.R32: FVCBrows.RC + $(R32Compiler) -fo$&.R32 $& +!endif + +# FVCBrows, Delphi mode only +!if $d(DelphiMode) +FVCBrows.$(uext): BTDEFINE.INC BRDefOpt.INC FVCBrows.PAS \ + FVCBrows.RC \ + Filer.$(uext) LowBrows.$(uext) MedBrows.$(uext) \ + HiBrows.$(uext) + $(Compile) $& +!endif + +# FVCReg, Delphi mode only +!if $d(DelphiMode) +FVCReg.$(uext): BTDEFINE.INC BRDefOpt.INC FVCReg.PAS \ + FVCBrows.RC \ + FVCBrows.$(uext) + $(Compile) $& +!endif + + +#------------------------------------------------------------ Packages + +T555_R30.DPL : T555_R30.DPK \ + Filer.DCU LowBrows.DCU MedBrows.DCU HiBrows.DCU \ + FVCBrows.DCU + $(Compile) $&.DPK + +T555_D30.DPL : T555_D30.DPK \ + Filer.DCU LowBrows.DCU MedBrows.DCU HiBrows.DCU \ + FVCBrows.DCU FVCReg.DCU + $(Compile) $&.DPK + +T555_R40.DPL : T555_R40.DPK \ + Filer.DCU LowBrows.DCU MedBrows.DCU HiBrows.DCU \ + FVCBrows.DCU + $(Compile) $&.DPK + +T555_D40.DPL : T555_D40.DPK \ + Filer.DCU LowBrows.DCU MedBrows.DCU HiBrows.DCU \ + FVCBrows.DCU FVCReg.DCU + $(Compile) $&.DPK + +T555_R50.DPL : T555_R50.DPK \ + Filer.DCU LowBrows.DCU MedBrows.DCU HiBrows.DCU \ + FVCBrows.DCU + $(Compile) $&.DPK + +T555_D50.DPL : T555_D50.DPK \ + Filer.DCU LowBrows.DCU MedBrows.DCU HiBrows.DCU \ + FVCBrows.DCU FVCReg.DCU + $(Compile) $&.DPK + +#------------------------------------------------------- Demo Programs + +$(DirDemos)\BigSort.EXE : $(DirDemos)\BIGSORT.PAS \ + MSort.$(uext) + cd $(DirDemos) + $(Compile) $& -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\BINDLIST.EXE : $(DirDemos)\BINDLIST.PAS \ + NWBase.$(uext) NWBind.$(uext) \ + NWConn.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\BTWDEMO.EXE : $(DirDemos)\BTWDEMO.PAS \ + $(DirDemos)\BTWSTuff.INC \ + Filer.$(uext) Reorg.$(uext) \ + Rebuild.$(uext) IsamTool.$(uext) \ + WBrowser.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\DB2ISAM.EXE : $(DirDemos)\DB2ISAM.PAS \ + BTBase.$(uext) BTIsBase.$(uext) \ + Filer.$(uext) IsamTool.$(uext) \ + DBImpExp.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\DelDemo.EXE : $(DirDemos)\DelDemo.DPR \ + $(DirDemos)\DelDemo1.PAS \ + $(DirDemos)\DelDemo2.PAS \ + $(DirDemos)\DelDemo3.PAS \ + $(DirDemos)\DelDemo4.PAS \ + $(DirDemos)\DelDemo5.PAS \ + BTBase.$(uext) BTIsBase.$(uext) \ + Filer.$(uext) Rebuild.$(uext) \ + Reorg.$(uext) VRebuild.$(uext) \ + VReorg.$(uext) \ + FVCBrows.$(uext) + cd $(DirDemos) + $(Compile) $&.DPR /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\Isam2DB.EXE : $(DirDemos)\Isam2DB.PAS \ + BTBase.$(uext) BTIsBase.$(uext) \ + Filer.$(uext) IsamTool.$(uext) \ + DBImpExp.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\MesExamp.EXE : $(DirDemos)\MesExamp.PAS \ + NWBase.$(uext) NWIPXSPX.$(uext) \ + NetBIOS.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\NBChat.EXE : $(DirDemos)\NBChat.PAS \ + NWBase.$(uext) NetBIOS.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\NBSend.EXE : $(DirDemos)\NBSend.PAS \ + NWBase.$(uext) NetBIOS.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\NETDEMO.EXE : $(DirDemos)\NETDEMO.PAS \ + BTBase.$(uext) BTIsBase.$(uext) \ + Filer.$(uext) Rebuild.$(uext) \ + Reorg.$(uext) VRebuild.$(uext) \ + VReorg.$(uext) \ + BROWSER.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) -o$(DirOProTPro) -u$(DirOProTPro) -i$(DirOProTPro) + cd $(DirBase) + +$(DirDemos)\NETINFO.EXE : $(DirDemos)\NETINFO.PAS \ + NWBase.$(uext) NWConn.$(uext) \ + NWFile.$(uext) NWMsg.$(uext) \ + NWTTS.$(uext) NWPrint.$(uext) \ + Share.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) -o$(DirOProTPro) -u$(DirOProTPro) -i$(DirOProTPro) + cd $(DirBase) + +$(DirDemos)\NISend.EXE : $(DirDemos)\NISend.PAS \ + NWBase.$(uext) NWIPXSPX.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\NSSend.EXE : $(DirDemos)\NSSend.PAS \ + NWBase.$(uext) NWIPXSPX.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\OPISDEMO.EXE : $(DirDemos)\OPISDEMO.PAS \ + $(DirDemos)\OPISMAIN.PAS \ + $(DirDemos)\OPISSTUF.INC \ + Filer.$(uext) Rebuild.$(uext) \ + OPBROW.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) -o$(DirOProTPro) -u$(DirOProTPro) -i$(DirOProTPro) + cd $(DirBase) + +$(DirDemos)\OWDEMO.EXE : $(DirDemos)\OWDEMO.PAS \ + Filer.$(uext) Reorg.$(uext) \ + WBrowser.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\SimpDemo.EXE : $(DirDemos)\SimpDemo.PAS \ + NWBase.$(uext) NWConn.$(uext) \ + NWSema.$(uext) \ + Filer.$(uext) Reorg.$(uext) \ + Reindex.$(uext) Rebuild.$(uext) \ + Browser.$(uext) + cd $(DirDemos) + $(Compile) $& -u$(DirBase) -i$(DirBase) -o$(DirOProTPro) -u$(DirOProTPro) -i$(DirOProTPro) + cd $(DirBase) + +$(DirDemos)\SPX2Way.EXE : $(DirDemos)\SPX2Way.PAS \ + NWBase.$(uext) NWIPXSPX.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\TRAFFIC.EXE : $(DirDemos)\TRAFFIC.PAS \ + Filer.$(uext) + cd $(DirDemos) + $(Compile) $& -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\TTSFiler.EXE : $(DirDemos)\TTSFiler.PAS \ + NWBase.$(uext) NWTTS.$(uext) \ + Filer.$(uext) + cd $(DirDemos) + $(Compile) $& -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\TVISDEMO.EXE : $(DirDemos)\TVISDEMO.PAS \ + $(DirDemos)\TVISSTUF.INC \ + Filer.$(uext) Rebuild.$(uext) \ + TVBROWS.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + diff --git a/src/wc_sdk/FILERMAK.PRO b/src/wc_sdk/FILERMAK.PRO new file mode 100644 index 0000000..4409b3c --- /dev/null +++ b/src/wc_sdk/FILERMAK.PRO @@ -0,0 +1,989 @@ +#********************************************************************* +#* FILER.MAK - MAKE file to rebuild B-Tree Filer * +#********************************************************************* + +#* ***** BEGIN LICENSE BLOCK ***** +#* Version: MPL 1.1 +#* +#* The contents of this file are subject to the Mozilla Public License Version +#* 1.1 (the "License"); you may not use this file except in compliance with +#* the License. You may obtain a copy of the License at +#* http://www.mozilla.org/MPL/ +#* +#* Software distributed under the License is distributed on an "AS IS" basis, +#* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License +#* for the specific language governing rights and limitations under the +#* License. +#* +#* The Original Code is TurboPower B-Tree Filer +#* +#* The Initial Developer of the Original Code is +#* TurboPower Software +#* +#* Portions created by the Initial Developer are Copyright (C) 1996-2002 +#* the Initial Developer. All Rights Reserved. +#* +#* Based in part on code written by Ralf Nagel +#* +#* Contributor(s): +#* +#* ***** END LICENSE BLOCK ***** *) + +# Notes: +# +# 1. This make file is designed to be used only with Borland's MAKE +# utility, version 3.6 and above (ie, it will work with the MAKE.EXE +# supplied with TP7, BP7, or Delphi 1.0, 2.0 and 3.0). +# +# 2. To use this MAKE file go to the \FILER diectory and type in a +# command of the form +# +# MAKE -fFILER.MAK compiler= options= +# +# at the DOS prompt (MAKE is assumed to be on the path). can +# be one of the following (case is sensitive) and must be supplied +# (there is no default): +# +# BP7R - real-mode BP7 +# BP7P - protected-mode BP7 +# BP7W - Windows-mode BP7 +# D1 - Delphi 1 +# D2 - Delphi 2 +# D3 - Delphi 3 +# D4 - Delphi 4 +# D5 - Delphi 5 +# +# can be one of the following, and if it not supplied the +# default value is shown (note that it is only required if the +# compiler value is BP7R or BP7P): +# +# NONE (neither Turbo or Object Professional present *DEFAULT*) +# OPRO (Object Professional present) +# TPRO (Turbo Professional present) +# BOTH (both Turbo or Object Professional present) +# +# A couple of examples: +# +# MAKE -fFILER.MAK Compiler=D1 +# +# will compile B-Tree Filer for use with Delphi 1. +# +# MAKE -fFILER.MAK Compiler=BP7R Options=OPRO +# +# will compile B-Tree Filer for use with BP7 real mode, using Object +# Professional. +# +# 3. The compilers, assembler and Windows resource compilers used by +# this MAKE file are assumed to be on the DOS path. If they are not, +# you will have to supply the full path to the compiler by altering +# the relevant macro below (look for the heading "Compiler Path +# Macros"). +# +# 4. If you do not have a copy of Turbo Assembler, be sure to comment +# out the HaveAssembler macro below. (To comment out a macro, insert +# a # character at the front of the line.) +# +# 5. If BP7R or BP7P is selected, the Turbo Vision parts of B-Tree +# Filer are always compiled. If you do not have TV, or don't want this +# behavior comment out the WantTV macro below. +# +# 6. If you want the B-Tree Filer units compiled with debug +# information, uncomment out the DEBUG macro below. +# +# 7. The directory structure assumed by this MAKE file is +# +# FILER +# +---DEMOS +# +# If you have a different directory structure, then alter the DirBase +# and DirDemos macros below. + + +#---------------------------------------------- Define Assembler Stuff +# Comment this line out if you do not have an assembler. If this macro +# is active, ASM files will be assembled into OBJ files if needed. +#HaveAssembler=1 + + +#------------------------------------------- Define Turbo Vision Stuff +# Comment this line out if you do not want to compile the Turbo Vision +# parts of B-Tree Filer. +WantTV=1 + + +#------------------------------------------- Define Turbo Vision Stuff +# Comment this line out if you do not want to compile the B-Tree Filer +# units with debug information. +# DEBUG=1 + + +#------------------------------------------ Define Directory Structure +# This set of macros define the directory structure for B-Tree Filer's +# source code files and demo programs. +DirBase=\FILER # this *must* be the default directory +DirDemos=$(DirBase)\DEMOS + +#------------------------------------------------ Compiler Path Macros +# These macros define the filenames of the command line compilers, +# assembler and resource compilers. +BP7Compiler=c:\bp7\bin\bpc.exe +Delphi1Compiler=c:\Delphi\bin\dcc.exe +Delphi2Compiler=c:\Delphi2\bin\dcc32.exe +Delphi3Compiler=c:\Delphi3\bin\dcc32.exe +Delphi4Compiler=c:\Delphi4\bin\dcc32.exe +Delphi5Compiler=c:\Delphi5\bin\dcc32.exe +TasmAssembler=c:\TASM\bin\tasm.exe +R16Compiler=c:\Delphi\bin\brcc.exe +R32Compiler=c:\Delphi2\bin\brcc32.exe + +# This macro shows the directories where your OPro and/or TPro units +# are found. The format of the macro's value follows the DOS PATH +# format, for example if you have the OPro units in C:\OPRO and the +# TPro units in C:\TPRO, specify the following: +# +# DirOproTPro=C:\OPRO;C:\TPRO +# +# If you have neither OPro or TPro then leave the macro undefined (ie, +# don't put anything after the equals sign). +DirOProTPro=C:\OPRO;C:\TPRO + + +#------------------------------- Other factors that affect compilation +# +# Note that you must edit BTDEFINE.INC to specify a network option +# and other conditional defines that affect B-Tree Filer + +###################################################################### +# From this point there are no more defines that need to be reviewed # +# or changed. # +###################################################################### + +# if the "compiler" macro is undefined show error +!if !$d(compiler) +!error You must invoke MAKE with compiler= parameter +!endif + +# if the "compiler" macro is invalid show error +!undef PrimTest +!if $(compiler) == BP7R +PrimTest=1 +!elif $(compiler) == BP7P +PrimTest=1 +!elif $(compiler) == BP7W +PrimTest=1 +!elif $(compiler) == D1 +PrimTest=1 +!elif $(compiler) == D2 +PrimTest=1 +!elif $(compiler) == D3 +PrimTest=1 +!elif $(compiler) == D4 +PrimTest=1 +!elif $(compiler) == D5 +PrimTest=1 +!endif +!if !$d(PrimTest) +!error The compiler value is invalid (use BP7R, BP7P, BP7W, D1, D2, D3, D4, D5) +!endif + +# make sure the "options" macro is valid +!undef HaveTPro +!undef HaveOPro +!undef HaveBoth +!if $(compiler) == BP7W +!undef options +!undef WantTV +!elif $(compiler) == D1 +!undef options +!undef WantTV +!elif $(compiler) == D2 +!undef options +!undef WantTV +!elif $(compiler) == D3 +!undef options +!undef WantTV +!elif $(compiler) == D4 +!undef options +!undef WantTV +!elif $(compiler) == D5 +!undef options +!undef WantTV +!endif +!if !$d(options) +options=NONE +!else +!undef PrimTest +!if $(options) == NONE +PrimTest=1 +!elif $(options) == OPRO +PrimTest=1 +HaveOPro=1 +!elif $(options) == TPRO +PrimTest=1 +HaveTPro=1 +!elif $(options) == BOTH +PrimTest=1 +HaveOPro=1 +HaveTPro=1 +HaveBoth=1 +!endif +!if !$d(PrimTest) +options=NONE +!endif +!endif + +# set up the debug directives for the compiles +!if $d(DEBUG) +!if $(__MAKE__)>=0x0370 +DBGDirs=-$$D+ -$$L+ -V +!else +DBGDirs=-$D+ -$L+ -V +!endif +!else +!if $(__MAKE__)>=0x0370 +DBGDirs=-$$D- -$$L- +!else +DBGDirs=-$D- -$L- +!endif +!endif + +# set up the unit extensions; create the compile macro +!if $(compiler) == BP7R +uext=TPU +Compile=$(BP7Compiler) -CD $(DBGDirs) /L +!elif $(compiler) == BP7P +uext=TPP +Compile=$(BP7Compiler) -CP $(DBGDirs) /L +!elif $(compiler) == BP7W +uext=TPW +Compile=$(BP7Compiler) -CW $(DBGDirs) /L +!elif $(compiler) == D1 +uext=DCU +Compile=$(Delphi1Compiler) $(DBGDirs) /L +!elif $(compiler) == D2 +uext=DCU +Compile=$(Delphi2Compiler) $(DBGDirs) /L +!elif $(compiler) == D3 +uext=DCU +Compile=$(Delphi3Compiler) $(DBGDirs) /L +!elif $(compiler) == D4 +uext=DCU +Compile=$(Delphi4Compiler) $(DBGDirs) /L +!elif $(compiler) == D5 +uext=DCU +Compile=$(Delphi5Compiler) $(DBGDirs) /L -LE$(DirBase) -LN$(DirBase) +!endif + +# create a couple of handy macros +!undef RMode +!undef PMode +!undef DOSMode +!undef WinMode +!undef Win32Mode +!undef DelphiMode +!if $(compiler) == BP7R +RMode=1 +DOSMode=1 +!elif $(compiler) == BP7P +PMode=1 +DOSMode=1 +!elif $(compiler) == BP7W +PMode=1 +WinMode=1 +!elif $(compiler) == D1 +PMode=1 +WinMode=1 +DelphiMode=1 +!elif $(compiler) == D2 +Win32Mode=1 +DelphiMode=1 +!elif $(compiler) == D3 +Win32Mode=1 +DelphiMode=1 +!elif $(compiler) == D4 +Win32Mode=1 +DelphiMode=1 +!elif $(compiler) == D5 +Win32Mode=1 +DelphiMode=1 +!endif + +# create a few macros to aid with presence/absence of OPro, TPro, TV +NeedOProFiles= +NeedTProFiles= +NeedTVFiles= +!if $d(HaveOPro) +NeedOProFiles=OProFiles +!endif +!if $d(HaveTPro) +NeedTProFiles=TProFiles +!endif +!if $d(WantTV) +NeedTVFiles=TVFiles +!endif + + +#---------------------------------Force all units/demos to be compiled +!if $(compiler) == BP7R +dummy: NonWin32Files RModeFiles DOSFiles \ + $(NeedOProFiles) $(NeedTProFiles) $(NeedTVFiles) \ + NWFiles CommonFiles +!elif $(compiler) == BP7P +dummy: NonWin32Files PModeFiles DOSFiles \ + $(NeedOProFiles) $(NeedTProFiles) $(NeedTVFiles) \ + NWFiles CommonFiles +!elif $(compiler) == BP7W +dummy: WBrowser.$(uext) \ + $(DirDemos)\BTWDEMO.EXE \ + $(DirDemos)\OWDemo.EXE \ + NonWin32Files PModeFiles NWFiles CommonFiles +!elif $(compiler) == D1 +dummy: DOSSupp.DCU FVCBrows.R16 FVCReg.$(uext) \ + NonWin32Files PModeFiles NWFiles DelphiFiles CommonFiles +!elif $(compiler) == D2 +dummy: FVCBrows.R32 FVCReg.$(uext) \ + Win32Files DelphiFiles CommonFiles +!elif $(compiler) == D3 +dummy: FVCBrows.R32 \ + T555_R30.DPL T555_D30.DPL \ + Win32Files DelphiFiles CommonFiles +!elif $(compiler) == D4 +dummy: FVCBrows.R32 \ + T555_R40.DPL T555_D40.DPL \ + Win32Files DelphiFiles CommonFiles +!elif $(compiler) == D5 +dummy: FVCBrows.R32 \ + T555_R50.DPL T555_D50.DPL \ + Win32Files DelphiFiles CommonFiles +!endif + +RModeFiles : EMSSupp.$(uext) EMSHeap.$(uext) \ + TPAlloc.$(uext) MSort.$(uext) \ + $(DirDemos)\BigSort.EXE + +PModeFiles : DPMI.$(uext) MSortP.$(uext) + +DOSFiles : TPCmd.$(uext) Browser.$(uext) \ + $(DirDemos)\DB2Isam.EXE $(DirDemos)\Isam2DB.EXE \ + $(DirDemos)\SimpDemo.EXE + +OProFiles : OPBrow.$(uext) \ + $(DirDemos)\OPISDEMO.EXE + +TProFiles : $(DirDemos)\NETDEMO.EXE + +TVFiles : TVBrows.$(uext) \ + $(DirDemos)\TVISDEMO.EXE + +NonWin32Files : NumKeys.OBJ NumKeys.$(uext) NetBIOS.$(uext) \ + CarrConv.$(uext) DBImpExp.$(uext) \ + $(DirDemos)\BindList.EXE $(DirDemos)\MesExamp.EXE \ + $(DirDemos)\NBChat.EXE $(DirDemos)\NBSend.EXE \ + $(DirDemos)\NETINFO.EXE $(DirDemos)\NISEND.EXE \ + $(DirDemos)\NSSEND.EXE $(DirDemos)\SPX2WAY.EXE \ + $(DirDemos)\TTSFILER.EXE + +Win32Files : NumKey32.$(uext) + +DelphiFiles : FVCBrows.$(uext) \ + $(DirDemos)\DelDemo.EXE + +NWFiles : NWBase.$(uext) NWBind.$(uext) NWConn.$(uext) \ + NWFile.$(uext) NWIPXSPX.$(uext) NWMsg.$(uext) \ + NWPrint.$(uext) NWSema.$(uext) NWTTS.$(uext) \ + OOPSema.$(uext) Share.$(uext) + +CommonFiles : BTDEFINE.INC \ + BTBase.$(uext) BTFileIO.$(uext) BTIsBase.$(uext) \ + Filer.$(uext) VRec.$(uext) Restruct.$(uext) \ + Reindex.$(uext) Rebuild.$(uext) VRebuild.$(uext) \ + Reorg.$(uext) VReorg.$(uext) FixToVar.$(uext) \ + IsamTool.$(uext) \ + LowBrows.$(uext) MedBrows.$(uext) HiBrows.$(uext) \ + $(DirDemos)\Traffic.EXE + +#-------------------------------------------- Assembly Language Source + +!if $d(HaveAssembler) +!if !$d(Win32Mode) +NumKeys.OBJ: NumKeys.ASM + $(TasmAssembler) $*; +!endif +!endif + + +#--------------------------------------------------------------- Units + +# DOSSupp, Delphi 1 only +!if $(compiler) == D1 +DOSSupp.$(uext): BTDEFINE.INC DOSSupp.PAS + $(Compile) $& +!endif + +# BaseSupp, not Delphi 2 or 3 +!if !$d(Win32Mode) +!if $(compiler) == D1 +BaseSupp.$(uext): BTDEFINE.INC BaseSupp.PAS DOSSupp.$(uext) + $(Compile) $& +!else +BaseSupp.$(uext): BTDEFINE.INC BaseSupp.PAS + $(Compile) $& +!endif +!endif + +# EMSSupp, BP7 real mode only +!if $d(RMode) +EMSSupp.$(uext): BTDEFINE.INC EMSSupp.PAS \ + BaseSupp.$(uext) + $(Compile) $& +!endif + +# EMSHeap, BP7 real mode only +!if $d(RMode) +EMSHeap.$(uext): BTDEFINE.INC EMSHeap.PAS EMSHeap.CFG \ + EMSSupp.$(uext) + $(Compile) $& +!endif + +# BTBase, all +BTBase.$(uext): BTDEFINE.INC BTBase.PAS + $(Compile) $& + +# BTFileIO, all +BTFileIO.$(uext): BTDEFINE.INC BTFileIO.PAS BTBase.$(uext) + $(Compile) $& + +# BTIsBase, all +!if !$d(Win32Mode) +BTIsBase.$(uext): BTDEFINE.INC BTIsBase.PAS \ + FILER.CFG ISNETSUP.INC BTLCKMGR.INC \ + BaseSupp.$(uext) \ + BTBase.$(uext) BTFileIO.$(uext) + $(Compile) $& +!else +BTIsBase.$(uext): BTDEFINE.INC BTIsBase.PAS \ + FILER.CFG ISNETSUP.INC BTLCKMGR.INC \ + BTBase.$(uext) BTFileIO.$(uext) + $(Compile) $& +!endif + +# DPMI, not Delphi 2 or 3 +!if !$d(Win32Mode) +DPMI.$(uext): DPMI.PAS + $(Compile) $& +!endif + +# NWBase, not Delphi 2 or 3 +!if !$d(Win32Mode) +!if $(compiler) == D1 +NWBase.$(uext): BTDEFINE.INC NWBase.PAS \ + DPMI.$(uext) DOSSupp.$(uext) + $(Compile) $& +!else +NWBase.$(uext): BTDEFINE.INC NWBase.PAS \ + DPMI.$(uext) + $(Compile) $& +!endif +!endif + +# NWBind, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWBind.$(uext): BTDEFINE.INC NWBind.PAS \ + NWBase.$(uext) + $(Compile) $& +!endif + +# NWConn, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWConn.$(uext): BTDEFINE.INC NWConn.PAS \ + NWBase.$(uext) NWBind.$(uext) + $(Compile) $& +!endif + +# NWFile, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWFile.$(uext): BTDEFINE.INC NWFile.PAS \ + NWBase.$(uext) NWConn.$(uext) + $(Compile) $& +!endif + +# NWIPXSPX, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWIPXSPX.$(uext): BTDEFINE.INC NWIPXSPX.PAS \ + NWBase.$(uext) + $(Compile) $& +!endif + +# NWMsg, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWMsg.$(uext): BTDEFINE.INC NWMsg.PAS \ + NWBase.$(uext) NWConn.$(uext) + $(Compile) $& +!endif + +# NWPrint, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWPrint.$(uext): BTDEFINE.INC NWPrint.PAS \ + NWBase.$(uext) NWBind.$(uext) NWConn.$(uext) \ + NWFile.$(uext) + + $(Compile) $& +!endif + +# NWSema, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWSema.$(uext): BTDEFINE.INC NWSema.PAS \ + NWBase.$(uext) NWConn.$(uext) + $(Compile) $& +!endif + +# NWTTS, not Delphi 2 or 3 +!if !$d(Win32Mode) +NWTTS.$(uext): BTDEFINE.INC NWTTS.PAS \ + NWBase.$(uext) + $(Compile) $& +!endif + +# OOPSema, not Delphi 2 or 3 +!if !$d(Win32Mode) +OOPSema.$(uext): BTDEFINE.INC OOPSema.PAS \ + NWBase.$(uext) NWSema.$(uext) + $(Compile) $& +!endif + +# Share, not Delphi 2 or 3 +!if !$d(Win32Mode) +!if $(compiler) == D1 +Share.$(uext): BTDEFINE.INC Share.PAS \ + DPMI.$(uext) DOSSupp.$(uext) + $(Compile) $& +!else +Share.$(uext): BTDEFINE.INC Share.PAS \ + DPMI.$(uext) + $(Compile) $& +!endif +!endif + +# NetBIOS, not Delphi 2 or 3 +!if !$d(Win32Mode) +!if $(compiler) == D1 +NetBIOS.$(uext): BTDEFINE.INC NetBIOS.PAS \ + DPMI.$(uext) DOSSupp.$(uext) + $(Compile) $& +!else +NetBIOS.$(uext): BTDEFINE.INC NetBIOS.PAS \ + DPMI.$(uext) + $(Compile) $& +!endif +!endif + +# Filer, all +!if $d(Win32Mode) +Filer.$(uext): BTDEFINE.INC FILER.PAS \ + FILER.INC ISAMBASE.INC ISAMLOW.INC ISAMWORK.INC \ + ISAMNWRK.INC \ + BTBase.$(uext) BTIsBase.$(uext) + $(Compile) $& +!else +!if $d(RMode) +Filer.$(uext): BTDEFINE.INC Filer.PAS \ + Filer.INC IsamBase.INC IsamLow.INC IsamWork.INC \ + IsamNWrk.INC \ + EMSSupp.$(uext) EMSHeap.$(uext) \ + BaseSupp.$(uext) BTBase.$(uext) BTIsBase.$(uext) + $(Compile) $& +!else +Filer.$(uext): BTDEFINE.INC Filer.PAS \ + Filer.INC IsamBase.INC IsamLow.INC IsamWork.INC \ + IsamNWrk.INC \ + BaseSupp.$(uext) BTBase.$(uext) BTIsBase.$(uext) + $(Compile) $& +!endif +!endif + +# VRec, all +VRec.$(uext): BTDEFINE.INC VRec.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) + $(Compile) $& + +# NumKeys, not Delphi 2 or 3 +!if !$d(Win32Mode) +NumKeys.$(uext): BTDEFINE.INC NumKeys.PAS \ + NumKeys.OBJ + $(Compile) $& +!endif + +# NumKey32, Delphi 2 or 3 only +!if $d(Win32Mode) +NumKey32.$(uext): BTDEFINE.INC NumKey32.PAS + $(Compile) $& +!endif + +# BufRecIO, all +BufRecIO.$(uext): BTDEFINE.INC BufRecIO.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + VRec.$(uext) + $(Compile) $& + +# Restruct, all +Restruct.$(uext): BTDEFINE.INC Restruct.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + VRec.$(uext) BufRecIO.$(uext) + $(Compile) $& + +# ReIndex, all +Reindex.$(uext): BTDEFINE.INC Reindex.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + VRec.$(uext) BufRecIO.$(uext) + $(Compile) $& + +# Rebuild, all +Rebuild.$(uext): BTDEFINE.INC Rebuild.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Restruct.$(uext) Reindex.$(uext) + $(Compile) $& + +# VRebuild, all +VRebuild.$(uext): BTDEFINE.INC VRebuild.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Vrec.$(uext) Restruct.$(uext) Reindex.$(uext) + $(Compile) $& + +# Reorg, all +Reorg.$(uext): BTDEFINE.INC Reorg.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Restruct.$(uext) Reindex.$(uext) + $(Compile) $& + +# VReorg, all +VReorg.$(uext): BTDEFINE.INC VReorg.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Vrec.$(uext) Restruct.$(uext) Reindex.$(uext) + $(Compile) $& + +# FixToVar, all +FixToVar.$(uext): BTDEFINE.INC FixToVar.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Restruct.$(uext) Reindex.$(uext) VReorg.$(uext) + $(Compile) $& + +# IsamTool, all +IsamTool.$(uext): BTDEFINE.INC IsamTool.PAS \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) + $(Compile) $& + +# TPAlloc, BP7 real mode +!if $d(RMode) +TPAlloc.$(uext): BTDEFINE.INC TPAlloc.PAS + $(Compile) $& +!endif + +# MSort, BP7 real mode +!if $d(RMode) +MSort.$(uext): BTDEFINE.INC MSort.PAS \ + MSortEMS.INC MSortINF.INC \ + EMSSupp.$(uext) + $(Compile) $& +!endif + +# MSortP, protected mode only +!if $d(PMode) +MSortP.$(uext): BTDEFINE.INC MSortP.PAS + $(Compile) $& +!endif + +# CarrConv, not Delphi 2 or 3 +!if !$d(Win32Mode) +CarrConv.$(uext): BTDEFINE.INC CarrConv.PAS + $(Compile) $& +!endif + +# DBImpExp, not Delphi 2 or 3 +!if !$d(Win32Mode) +DBImpExp.$(uext): BTDEFINE.INC DBImpExp.PAS \ + DBImpExp.IN1 DBImpExp.IN2 \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + CarrConv.$(uext) + $(Compile) $& +!endif + +# TPCmd, BP7R and BP7P only +!if $d(DOSMode) +TPCmd.$(uext): BTDEFINE.INC TPDEFINE.INC TPCmd.PAS + $(Compile) $& +!endif + +# Browser, BP7R and BP7P only +!if $d(DOSMode) +Browser.$(uext): BTDEFINE.INC TPDEFINE.INC Browser.PAS \ + Browser.INC \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Vrec.$(uext) TPCmd.$(uext) + $(Compile) $& /m -o$(DirOProTPro) -u$(DirOProTPro) -i$(DirOProTPro) +!endif + +# LowBrows, all +LowBrows.$(uext): BTDEFINE.INC BRDefOpt.INC LowBrows.PAS \ + BRLISAM.INC \ + BTBase.$(uext) BTIsBase.$(uext) Filer.$(uext) \ + Vrec.$(uext) + $(Compile) $& + +# MedBrows, all +MedBrows.$(uext): BTDEFINE.INC BRDefOpt.INC MedBrows.PAS \ + LowBrows.$(uext) + $(Compile) $& + +# HiBrows, all +HiBrows.$(uext): BTDEFINE.INC BRDefOpt.INC HiBrows.PAS \ + LowBrows.$(uext) MedBrows.$(uext) + $(Compile) $& + +# OPBrow, DOS mode only +!if $d(DOSMode) +OPBrow.$(uext): BTDEFINE.INC BRDefOpt.INC OPBrow.PAS \ + OPBrow.ICD \ + DPMI.$(uext) \ + Filer.$(uext) LowBrows.$(uext) MedBrows.$(uext) \ + HiBrows.$(uext) + $(Compile) $& /m -i$(DirOProTPro) -o$(DirOProTPro) -u$(DirOProTPro) +!endif + +# TVBrows, DOS mode only with WantTV +!if $d(DOSMode) +!if $d(WantTV) +TVBrows.$(uext): BTDEFINE.INC BRDefOpt.INC TVBrows.PAS \ + Filer.$(uext) LowBrows.$(uext) MedBrows.$(uext) \ + HiBrows.$(uext) + $(Compile) $& +!endif +!endif + +# WBrowser, BP7W mode only +!if $(compiler) == BP7W +WBrowser.$(uext): BTDEFINE.INC BRDefOpt.INC WBrowser.PAS \ + Filer.$(uext) LowBrows.$(uext) MedBrows.$(uext) \ + HiBrows.$(uext) + $(Compile) $& +!endif + +# FVCBrows.R16, Delphi 1 only +!if $(compiler) == D1 +FVCBrows.R16: FVCBrows.RC + $(R16Compiler) -fo$&.R16 $& +!endif + +# FVCBrows.R32, Delphi 2 and 3 only +!if $d(Win32Mode) +FVCBrows.R32: FVCBrows.RC + $(R32Compiler) -fo$&.R32 $& +!endif + +# FVCBrows, Delphi mode only +!if $d(DelphiMode) +FVCBrows.$(uext): BTDEFINE.INC BRDefOpt.INC FVCBrows.PAS \ + FVCBrows.RC \ + Filer.$(uext) LowBrows.$(uext) MedBrows.$(uext) \ + HiBrows.$(uext) + $(Compile) $& +!endif + +# FVCReg, Delphi mode only +!if $d(DelphiMode) +FVCReg.$(uext): BTDEFINE.INC BRDefOpt.INC FVCReg.PAS \ + FVCBrows.RC \ + FVCBrows.$(uext) + $(Compile) $& +!endif + + +#------------------------------------------------------------ Packages + +T555_R30.DPL : T555_R30.DPK \ + Filer.DCU LowBrows.DCU MedBrows.DCU HiBrows.DCU \ + FVCBrows.DCU + $(Compile) $&.DPK + +T555_D30.DPL : T555_D30.DPK \ + Filer.DCU LowBrows.DCU MedBrows.DCU HiBrows.DCU \ + FVCBrows.DCU FVCReg.DCU + $(Compile) $&.DPK + +T555_R40.DPL : T555_R40.DPK \ + Filer.DCU LowBrows.DCU MedBrows.DCU HiBrows.DCU \ + FVCBrows.DCU + $(Compile) $&.DPK + +T555_D40.DPL : T555_D40.DPK \ + Filer.DCU LowBrows.DCU MedBrows.DCU HiBrows.DCU \ + FVCBrows.DCU FVCReg.DCU + $(Compile) $&.DPK + +T555_R50.DPL : T555_R50.DPK \ + Filer.DCU LowBrows.DCU MedBrows.DCU HiBrows.DCU \ + FVCBrows.DCU + $(Compile) $&.DPK + +T555_D50.DPL : T555_D50.DPK \ + Filer.DCU LowBrows.DCU MedBrows.DCU HiBrows.DCU \ + FVCBrows.DCU FVCReg.DCU + $(Compile) $&.DPK + +#------------------------------------------------------- Demo Programs + +$(DirDemos)\BigSort.EXE : $(DirDemos)\BIGSORT.PAS \ + MSort.$(uext) + cd $(DirDemos) + $(Compile) $& -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\BINDLIST.EXE : $(DirDemos)\BINDLIST.PAS \ + NWBase.$(uext) NWBind.$(uext) \ + NWConn.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\BTWDEMO.EXE : $(DirDemos)\BTWDEMO.PAS \ + $(DirDemos)\BTWSTuff.INC \ + Filer.$(uext) Reorg.$(uext) \ + Rebuild.$(uext) IsamTool.$(uext) \ + WBrowser.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\DB2ISAM.EXE : $(DirDemos)\DB2ISAM.PAS \ + BTBase.$(uext) BTIsBase.$(uext) \ + Filer.$(uext) IsamTool.$(uext) \ + DBImpExp.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\DelDemo.EXE : $(DirDemos)\DelDemo.DPR \ + $(DirDemos)\DelDemo1.PAS \ + $(DirDemos)\DelDemo2.PAS \ + $(DirDemos)\DelDemo3.PAS \ + $(DirDemos)\DelDemo4.PAS \ + $(DirDemos)\DelDemo5.PAS \ + BTBase.$(uext) BTIsBase.$(uext) \ + Filer.$(uext) Rebuild.$(uext) \ + Reorg.$(uext) VRebuild.$(uext) \ + VReorg.$(uext) \ + FVCBrows.$(uext) + cd $(DirDemos) + $(Compile) $&.DPR /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\Isam2DB.EXE : $(DirDemos)\Isam2DB.PAS \ + BTBase.$(uext) BTIsBase.$(uext) \ + Filer.$(uext) IsamTool.$(uext) \ + DBImpExp.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\MesExamp.EXE : $(DirDemos)\MesExamp.PAS \ + NWBase.$(uext) NWIPXSPX.$(uext) \ + NetBIOS.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\NBChat.EXE : $(DirDemos)\NBChat.PAS \ + NWBase.$(uext) NetBIOS.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\NBSend.EXE : $(DirDemos)\NBSend.PAS \ + NWBase.$(uext) NetBIOS.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\NETDEMO.EXE : $(DirDemos)\NETDEMO.PAS \ + BTBase.$(uext) BTIsBase.$(uext) \ + Filer.$(uext) Rebuild.$(uext) \ + Reorg.$(uext) VRebuild.$(uext) \ + VReorg.$(uext) \ + BROWSER.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) -o$(DirOProTPro) -u$(DirOProTPro) -i$(DirOProTPro) + cd $(DirBase) + +$(DirDemos)\NETINFO.EXE : $(DirDemos)\NETINFO.PAS \ + NWBase.$(uext) NWConn.$(uext) \ + NWFile.$(uext) NWMsg.$(uext) \ + NWTTS.$(uext) NWPrint.$(uext) \ + Share.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) -o$(DirOProTPro) -u$(DirOProTPro) -i$(DirOProTPro) + cd $(DirBase) + +$(DirDemos)\NISend.EXE : $(DirDemos)\NISend.PAS \ + NWBase.$(uext) NWIPXSPX.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\NSSend.EXE : $(DirDemos)\NSSend.PAS \ + NWBase.$(uext) NWIPXSPX.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\OPISDEMO.EXE : $(DirDemos)\OPISDEMO.PAS \ + $(DirDemos)\OPISMAIN.PAS \ + $(DirDemos)\OPISSTUF.INC \ + Filer.$(uext) Rebuild.$(uext) \ + OPBROW.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) -o$(DirOProTPro) -u$(DirOProTPro) -i$(DirOProTPro) + cd $(DirBase) + +$(DirDemos)\OWDEMO.EXE : $(DirDemos)\OWDEMO.PAS \ + Filer.$(uext) Reorg.$(uext) \ + WBrowser.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\SimpDemo.EXE : $(DirDemos)\SimpDemo.PAS \ + NWBase.$(uext) NWConn.$(uext) \ + NWSema.$(uext) \ + Filer.$(uext) Reorg.$(uext) \ + Reindex.$(uext) Rebuild.$(uext) \ + Browser.$(uext) + cd $(DirDemos) + $(Compile) $& -u$(DirBase) -i$(DirBase) -o$(DirOProTPro) -u$(DirOProTPro) -i$(DirOProTPro) + cd $(DirBase) + +$(DirDemos)\SPX2Way.EXE : $(DirDemos)\SPX2Way.PAS \ + NWBase.$(uext) NWIPXSPX.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\TRAFFIC.EXE : $(DirDemos)\TRAFFIC.PAS \ + Filer.$(uext) + cd $(DirDemos) + $(Compile) $& -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\TTSFiler.EXE : $(DirDemos)\TTSFiler.PAS \ + NWBase.$(uext) NWTTS.$(uext) \ + Filer.$(uext) + cd $(DirDemos) + $(Compile) $& -u$(DirBase) -i$(DirBase) + cd $(DirBase) + +$(DirDemos)\TVISDEMO.EXE : $(DirDemos)\TVISDEMO.PAS \ + $(DirDemos)\TVISSTUF.INC \ + Filer.$(uext) Rebuild.$(uext) \ + TVBROWS.$(uext) + cd $(DirDemos) + $(Compile) $& /m -u$(DirBase) -i$(DirBase) + cd $(DirBase) + diff --git a/src/wc_sdk/FVCBROWS.R16 b/src/wc_sdk/FVCBROWS.R16 new file mode 100644 index 0000000000000000000000000000000000000000..6f9ecf760bdd11574fb596aaa0062ea9b0bbe65e GIT binary patch literal 413 zcmY*UF%H5o47>tT$1*Z9GDZqRMnnQ@q=Mintd+9lS$z}|W4JhJtGcm$IbY9h+TeMA z*=z6Lk6RCg*Z?O0hnfv`M8J{!6#EHC9{?T=UnRAh3{tG(@JGt*CqC9Ld#x_|yq8$? p-A{1&Oxe5sgL*S2>R^mEyfZ_L6BeEm@+>Bp5JeM-il$mf`vbV~a=ZWl literal 0 HcmV?d00001 diff --git a/src/wc_sdk/FVCBROWS.R32 b/src/wc_sdk/FVCBROWS.R32 new file mode 100644 index 0000000000000000000000000000000000000000..de9788606b6f7508d0330fcdf366c464253fa48c GIT binary patch literal 476 zcmZusyAHxI47>tT$1*Z@WQ>#!84(Grl>ot~uvY4l&+11ZF@}rN^dWJo?bF#gy8uu# zLP$Znf-iuEN(dV~aK#fAXWY=@g*z@}32O1`NPZZjz)m_feKPi$NbLZA=(<#xNihrq zYiz{BVhO1*r&|N`8u^4RWfdaIxA2d1E>z{LSCih-T6B&$H_o?wnz&W7?i77m@od~_ z^0%Tp@v(N^Yjv8Bd&yaYM8v&+VT{+kG1{=p=)KQebatpSncnnXW;|J%SsMNT DsJnOz literal 0 HcmV?d00001 diff --git a/src/wc_sdk/FVCBROWS.RC b/src/wc_sdk/FVCBROWS.RC new file mode 100644 index 0000000..836436e --- /dev/null +++ b/src/wc_sdk/FVCBROWS.RC @@ -0,0 +1,60 @@ +/********************************************************************/ +/* FVCBROWS.RC - Resource script for browser component */ +/********************************************************************/ + +/* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** */ + + +TFVCBROWSER BITMAP +{ + '42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00' + '00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00' + '00 00 20 01 00 00 00 00 00 00 00 00 00 00 10 00' + '00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80' + '00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80' + '00 00 C0 C0 C0 00 80 80 80 00 00 00 FF 00 00 FF' + '00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF' + '00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33' + '33 33 33 33 33 30 00 00 00 00 00 00 00 03 33 33' + '33 30 FF FF FF FF FF 07 77 03 33 33 33 30 F4 44' + '44 44 FF 0F 07 03 33 33 33 30 FF FF FF FF FF 0F' + '77 03 33 33 33 30 F4 44 44 4F FF 00 00 03 33 33' + '33 30 44 44 44 44 44 07 77 03 33 33 33 30 4F FF' + 'FF FF 44 07 77 03 33 33 43 30 44 44 44 44 44 07' + '77 03 33 33 44 30 F4 44 44 4F FF 07 77 03 33 34' + '44 40 FF FF FF FF FF 07 77 03 33 43 44 30 F4 44' + '44 44 FF 00 00 03 33 43 43 30 FF FF FF FF FF 07' + '77 03 33 43 33 30 F4 44 44 4F FF 0F 07 03 33 43' + '33 30 FF FF FF FF FF 0F F7 03 33 43 33 30 00 00' + '00 00 00 00 00 03 33 33 33 33 33 33 33 33 33 33' + '33 33 33 33 33 33 33 33 33 33 33 33 33 33 38 38' + '88 33 83 38 38 33 38 33 33 33 38 33 33 83 88 88' + '38 33 38 33 33 33 38 33 88 33 83 38 38 38 38 33' + '33 33 38 38 33 33 38 83 38 83 88 33 33 33 38 33' + '88 83 38 83 38 33 38 33 33 33 33 33 33 33 33 33' + '33 33 33 33 33 33' +} + diff --git a/src/wc_sdk/NUMKEYS.ASM b/src/wc_sdk/NUMKEYS.ASM new file mode 100644 index 0000000..333a3f6 --- /dev/null +++ b/src/wc_sdk/NUMKEYS.ASM @@ -0,0 +1,509 @@ +;* ***** BEGIN LICENSE BLOCK ***** +;* Version: MPL 1.1 +;* +;* The contents of this file are subject to the Mozilla Public License Version +;* 1.1 (the "License"); you may not use this file except in compliance with +;* the License. You may obtain a copy of the License at +;* http://www.mozilla.org/MPL/ +;* +;* Software distributed under the License is distributed on an "AS IS" basis, +;* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License +;* for the specific language governing rights and limitations under the +;* License. +;* +;* The Original Code is TurboPower B-Tree Filer +;* +;* The Initial Developer of the Original Code is +;* TurboPower Software +;* +;* Portions created by the Initial Developer are Copyright (C) 1996-2002 +;* the Initial Developer. All Rights Reserved. +;* +;* Based in part on code written by Ralf Nagel +;* +;* Contributor(s): +;* +;* ***** END LICENSE BLOCK ***** + +;****************************************************** Macros and Equates + +SetZero MACRO Reg + XOR Reg,Reg ;Reg = 0 + ENDM + +ChkZero MACRO Reg + OR Reg,Reg ;Reg = 0? + ENDM + +BitsPerChar EQU DH +BPCdelta EQU DL +BitCount EQU BH +BitsLeft EQU BH +CharsLeft EQU BL + +DATA SEGMENT BYTE PUBLIC ;!!.22 + EXTRN ProcPtr : WORD ;!!.22 +DATA ENDS ;!!.22 + +;****************************************************** Code + +CODE SEGMENT BYTE PUBLIC + + ASSUME CS:CODE,DS:DATA + + PUBLIC Pack4BitKey, Pack5BitKeyUC, Pack6BitKeyUC, Pack6BitKey + PUBLIC Unpack4BitKey, Unpack5BitKeyUC, Unpack6BitKeyUC, Unpack6BitKey + PUBLIC DescendingKey + +;****************************************************** Pack4 + +;characters ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 +Pack4Table DB 1, 2, 0, 3, 0, 4, 5, 0, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 + +Pack4 PROC NEAR + + CMP AL,'(' ;less than '('? + JB P6zeroIt ;map to 0 + CMP AL,'9' ;greater than '9'? + JA P6zeroIt ;map to 0 + PUSH BX ;save BX + MOV BX,Offset Pack4Table ;CS:BX => Pack4Table + SUB AL,'(' + XLAT BYTE PTR CS:[0] ;map character to 0-15 + POP BX ;restore BX + RET + +Pack4 ENDP + +;****************************************************** Pack5 + +Pack5 PROC NEAR + + CMP AL,'z' ;greater than 'z'? + JA P6zeroIt ;map to 0 + CMP AL,'a' ;less than 'a'? + JB P5checkAtoZ ;check for 'A'..'Z' + SUB AL,96 ;in range 'a'-'z' -- map to 1-26 + RET + +P5checkAtoZ: + CMP AL,'A' ;less than 'A'? + JB P6zeroIt ;map to 0 + CMP AL,'Z' ;greater than 'Z'? + JA P6zeroIt ;map to 0 + SUB AL,64 ;in range 'A'-'Z' -- map to 1-26 + RET + +Pack5 ENDP + +;****************************************************** Pack6UC + +Pack6UC PROC NEAR + + CMP AL,'_' ;greater than '_'? + JA P6UCcheckaz ;check for 'a'-'z' + CMP AL,'!' ;less than '!'? + JB P6zeroIt ;map to 0 + SUB AL,32 ;in range -- map to 1-63 + RET + +P6UCcheckaz: + CMP AL,'z' ;greater than 'z'? + JA P6zeroIt ;map to 0 + CMP AL,'a' ;less than 'a'? + JB P6zeroIt ;map to 0 + SUB AL,64 ;in range 'a'-'z' -- map to 33-58 + RET + +Pack6UC ENDP + +;****************************************************** Pack6 + +Pack6 PROC NEAR + + CMP AL,'z' ;greater than 'z'? + JA P6zeroIt ;map to 0 + CMP AL,'a' ;less than 'a'? + JB P6checkAtoZ ;check for 'A'-'Z' + SUB AL,60 ;in range 'a'-'z' -- map to 37-62 + RET + +P6checkAtoZ: + CMP AL,'A' ;less than 'A'? + JB P6check0to9 ;check for '0'-'9' + CMP AL,'Z' ;greater than 'Z'? + JA P6zeroIt ;map to 0 + SUB AL,54 ;in range 'A'-'Z' -- map to 11-36 + RET + +P6check0to9: + CMP AL,'0' ;less than '0'? + JB P6zeroIt ;map to 0 + CMP AL,'9' ;greater than '9'? + JA P6zeroIt ;map to 0 + SUB AL,47 ;in range '0'-'9' -- map to 1-10 + RET + +P6zeroIt: + SetZero AL + RET + +Pack6 ENDP + +;****************************************************** Pack4BitKey + +;function Pack4BitKey(Src : string; Len : Byte) : string; +;Pack the Source string into sequences of 4 bits (max length = Len) + +Pack4BitKey: + + MOV BitsPerChar,4 ;number of bits per character = 4 + MOV BPCdelta,4 ;BPCdelta = 8-4 + MOV ProcPtr,Offset Pack4 ;Load procedure offset + JMP SHORT PackKey + +;****************************************************** Pack5BitKeyUC + +;function Pack5BitKeyUC(Src : string; Len : Byte) : string; +;Pack the Source string into sequences of 5 bits (max length = Len) + +Pack5BitKeyUC: + + MOV BitsPerChar,5 ;number of bits per character = 5 + MOV BPCdelta,3 ;BPCdelta = 8-5 + MOV ProcPtr,Offset Pack5 ;Load procedure offset + JMP SHORT PackKey + +;****************************************************** Pack6BitKeyUC + +;function Pack6BitKey(Src : string; Len : Byte) : string; +;Pack the Source string into sequences of 6 bits (max length = Len) + +Pack6BitKeyUC: + + MOV BitsPerChar,6 ;number of bits per character = 6 + MOV BPCdelta,2 ;BPCdelta = 8-6 + MOV ProcPtr,Offset Pack6UC ;Load procedure offset + JMP SHORT PackKey + +;****************************************************** Pack6BitKey + +;function Pack6BitKey(Src : string; Len : Byte) : string; +;Pack the Source string into sequences of 6 bits (max length = Len) + +Pack6BitKey: + + MOV BitsPerChar,6 ;number of bits per character = 6 + MOV BPCdelta,2 ;BPCdelta = 8-6 + MOV ProcPtr,Offset Pack6 ;Load procedure offset + + ;falls through into PackKey + +;****************************************************** PackKey + +;Primitive routine to make a key + +PLen EQU BYTE PTR [BP+6] ;!!.22 +PSrc EQU DWORD PTR [BP+8] ;!!.22 +PDest EQU DWORD PTR [BP+12] ;!!.22 +LProcP EQU WORD PTR [BP-2] ;!!.22 +L2 EQU WORD PTR [BP-4] ;!!.22 + +PackKey PROC FAR + PUSH BP ;!!.22 + MOV BP,SP ;Set up stack frame !!.22 + SUB SP,4 ;!!.22 + MOV AX,ProcPtr ;!!.22 + MOV LProcP,AX ;!!.22 + PUSH DS ;Save DS + CLD ;Go forward + LDS SI,PSrc ;DS:SI -> Src[0] + LES DI,PDest ;ES:DI -> Result[0] + SetZero AH ;AX = Len + MOV AL,PLen + STOSB ;Set the result's length byte + MOV L2,DI ;L2 = Ofs(Result[Len+1]) !!.22 + ADD L2,AX ;!!.22 + SetZero AH ;AH = Next byte to plug in + LODSB ;AL = Length(Src) + MOV CharsLeft,AL ;BL = # of chars left in Src + SetZero BitCount ;BH = # of bits in AH + +PMain: + CMP DI,L2 ;string full? !!.22 + JAE PExit ;if so, we're done + ChkZero CharsLeft ;any characters left in Src? + JZ PFinish + LODSB ;load next character + DEC CharsLeft ;decrement loop counter + CALL LProcP ;pack character in AL !!.22 + + MOV CL,BPCdelta ;shift bottom of AL into top + SHL AL,CL + SetZero CH ;set loop count + MOV CL,BitsPerChar +PLoop: + CMP BitCount,8 ;do we have 8 bits yet? + JB PNext + MOV ES:[DI],AH ;store character in AH at ES:DI + INC DI ;advance string index + SetZero BitCount ;Reset BH to 0 +PNext: + ROL AL,1 ;rotate high bit of AL into CF + RCL AH,1 ;rotate it from CF into low bit of AH + INC BitCount ;increment counter + LOOP PLoop ;next bit + + JMP SHORT PMain ;do it again + +PFinish: + ChkZero BitCount ;anything left in AH? + JZ PZeroPad ;if not, pad with 0's + MOV CL,8 ;move the bits in AH up into place + SUB CL,BitCount + SHL AH,CL + MOV ES:[DI],AH ;store character in AH at ES:DI + INC DI ;advance string index + +PZeroPad: ;pad to end of string with zeros !!.22 + MOV CX,L2 ;CX = # of zeros to write + SUB CX,DI + SetZero AL ;AL = 0 + REP STOSB ;fill with zeros if CX > 0 + +PExit: + POP DS + MOV SP,BP ;!!.22 + POP BP ;!!.22 + RET 6 ;remove parameters and return + +PackKey ENDP + +;****************************************************** Unpack4 + +; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 +Unpack4Table DB ' ','(',')','+','-','.','0','1','2','3','4','5','6','7','8','9' + +Unpack4 PROC NEAR + + PUSH BX ;save BX + XCHG AH,AL ;switch AH and AL + MOV BX,Offset Unpack4Table ;CS:BX => Unpack4Table + XLAT BYTE PTR CS:[0] ;map character to 0-15 + XCHG AH,AL ;switch AH and AL + POP BX ;restore BX + RET + +Unpack4 ENDP + +;****************************************************** Unpack5 + +Unpack5 PROC NEAR + + ChkZero AH ;AH = 0? + JZ U6space ;if so, return a space + ADD AH,64 ;map to 'A'..'Z' + RET + +Unpack5 ENDP + +;****************************************************** Unpack6UC + +Unpack6UC PROC NEAR + + ChkZero AH,AH ;AH = 0? + JZ U6space ;if so, return a space + ADD AH,32 ;else, map to '!'-'_' + RET + +Unpack6UC ENDP + +;****************************************************** Unpack6 + +Unpack6 PROC NEAR + + ChkZero AH ;AH = 0? + JZ U6space ;if so, return a space + CMP AH,37 ;less than 37? + JB U6checkAtoZ ;check for 'A'-'Z' + ADD AH,60 ;in range 37-62 -- map to 'a'-'z' + RET + +U6checkAtoZ: + CMP AH,11 ;less than 11? + JB U60to9 + ADD AH,54 ;in range 37-62 -- map to 'a'-'z' + RET + +U60to9: + ADD AH,47 ;in range 1-10 -- map to '0'-'9' + RET + +U6space: + MOV AH,' ' + RET + +Unpack6 ENDP + +;****************************************************** Unpack4BitKey + +;function Unpack4BitKey(Src : string) : string; +;Unpack a key created by Pack4BitKey + +Unpack4BitKey: + + MOV BitsPerChar,4 ;number of bits per character = 4 + MOV ProcPtr,Offset Unpack4 ;Load procedure offset + JMP SHORT UnpackKey + +;****************************************************** Unpack5BitKeyUC + +;function Unpack5BitKeyUC(Src : string) : string; +;Unpack a key created by Pack5BitKeyUC + +Unpack5BitKeyUC: + + MOV BitsPerChar,5 ;number of bits per character = 5 + MOV ProcPtr,Offset Unpack5 ;Load procedure offset + JMP SHORT UnpackKey + +;****************************************************** Unpack6BitKeyUC + +;function Unpack6BitKeyUC(Src : string) : string; +;Unpack a key created by Pack6BitKeyUC + +Unpack6BitKeyUC: + + MOV BitsPerChar,6 ;number of bits per character = 6 + MOV ProcPtr,Offset Unpack6UC ;Load procedure offset + JMP SHORT UnpackKey + +;****************************************************** Unpack6BitKey + +;function Unpack6BitKey(Src : string) : string; +;Unpack a key created by Pack6BitKey + +Unpack6BitKey: + + MOV BitsPerChar,6 ;number of bits per character = 6 + MOV ProcPtr,Offset Unpack6 ;Load procedure offset + + ;falls through into UnpackKey + +;****************************************************** UnpackKey + +;Primitive routine to unpack a packed key + +USrc EQU DWORD PTR [BP+6] ;!!.22 +UDest EQU DWORD PTR [BP+10] ;!!.22 +LProcP EQU WORD PTR [BP-2] ;!!.22 + +UnpackKey PROC FAR + PUSH BP ;!!.22 + MOV BP,SP ;Set up stack frame !!.22 + SUB SP,2 ;!!.22 + MOV AX,ProcPtr ;!!.22 + MOV LProcP,AX ;!!.22 + PUSH DS ;Save DS + CLD ;Go forward + LDS SI,USrc ;DS:SI -> Src[0] + LES DI,UDest ;ES:DI -> Result[0] + LODSB ;AL = Length(Src) + MOV CharsLeft,AL ;BL = # of chars left in Src + SetZero BitsLeft ;BH = # of bits in AL + PUSH DI ;save offset of Result[0] + +UMain: + ChkZero CharsLeft ;any characters left in Src? + JZ UFinish + + ;rotate next packed char into AH + + SetZero CH ;set loop count + MOV CL,BitsPerChar + SetZero AH ;AH is empty +ULoop: + ChkZero BitsLeft ;any bits left in AL? + JNZ UNext + LODSB ;reload AL + DEC CharsLeft ;decrement counter + MOV BitsLeft,8 ;Reset BH to 8 +UNext: + ROL AL,1 ;rotate high bit of AL into CF + RCL AH,1 ;rotate it from CF into low bit of AH + DEC BitsLeft ;decrement bit counter + LOOP ULoop ;next bit + + CALL LProcP ;unpack char in AH !!.22 + INC DI ;advance string index + MOV ES:[DI],AH ;store the unpacked character + JMP SHORT UMain ;do it again + +UFinish: + CMP BitsLeft,BitsPerChar ;full character left in AL? + JB UExit ;if not, we're done + MOV CL,8 ;move the bits in AL down into place + SUB CL,BitsPerChar ;!!.55 + SHR AL,CL + MOV AH,AL ;move it into AH + CALL LProcP ;unpack char in AH !!.22 + INC DI ;advance string index + MOV ES:[DI],AH ;store character in AH at ES:DI + +UExit: + MOV AX,DI ;AX = DI + POP DI ;Restore pointer to length byte + SUB AX,DI ;Get length of our string + STOSB ;Set length byte + POP DS ;restore DS + MOV SP,BP ;!!.22 + POP BP ;!!.22 + RET 4 ;remove parameter and return + +UnpackKey ENDP + +;****************************************************** MakeDescendingKey + +;function DescendingKey(S : string; MaxLen : Byte) : string; +;Invert values in S to allow descending sorts, pad to MaxLen with #$FF + +dkLen EQU BYTE PTR SS:[BX+4] +dkSrc EQU DWORD PTR SS:[BX+6] +dkDest EQU DWORD PTR SS:[BX+10] + +DescendingKey PROC FAR + + MOV BX,SP ;Set up stack frame + PUSH DS ;Save DS + CLD ;go forward + XOR DH,DH ;DX = MaxLen + MOV DL,dkLen + LDS SI,dkSrc ;DS:SI => S + LES DI,dkDest ;ES:DI => result + XOR AH,AH ;AX = CX = length(S) + LODSB + MOV CX,AX + MOV AL,DL ;set length byte of result + STOSB + SUB DX,CX ;calculate amount of padding + JCXZ dkPad ;pad to maximum width if string empty +dkAgain: + LODSB ;get next byte + NOT AL ;invert + STOSB ;store it + LOOP dkAgain +dkPad: + CMP DX,0 ;DX > 0? !!.41 + JLE dkDone ; !!.41 + MOV AL,0FFh ;pad with $FF + MOV CX,DX ;loop count into CX + REP STOSB ;pad the string +dkDone: + POP DS ;restore DS + RET 6 ;remove parameters and return + +DescendingKey ENDP + +CODE ENDS + + END diff --git a/src/wc_sdk/NUMKEYS.OBJ b/src/wc_sdk/NUMKEYS.OBJ new file mode 100644 index 0000000000000000000000000000000000000000..dfae271e3f904b03e90f9633c47a19a07e431e8f GIT binary patch literal 992 zcmY+CUr19?9LIm>?s~Vb|3JeCOmF#b<(hianRYSPoFdi~ol03~f>EIvchix?x**8h z3^YV6B(#Sh5h{uG;EQ;#7zS!0805pS1;vye0v}{-o#Qm^>3sP9zUT7$9Ig}#(Uz`` zs zQsMOK2nBGL;Kc9<19X|uYAhdBgBE~7sDMPK>N2yLM2VCNq0|8u)HSu$rW$K46b&Zf zUVOc!#%QW4xKe4YGGDJZ-9g|vIxrjz9wLwi6Yz~_($9~?c7VCVaKAeWFgAD`H)A8; z-tXQ-z#onG+dT*pBJqEFNB}1zahbW!WVV!5S}O2@J_K(M+y9mu0EltXQ2GiDjh~?K zs~`$gKt}A`3>bM7ZH7)|JXa zvqLSM7ISnQDQIyaouoaEQ+r*3bk(>Ur!&YxF2*8p3<+r1=(H6oMg%BbMOE3+$Wp@q%uz#1F2v+p(MmRJ2`;;{s? zm-*R0lc}B`w-y=Tv}d!=>vQw?3;6|x!iz<9eZHAQq+jpzHOZ{so+&A%?t+tf7xpaTC&2zgV@;qWTPdZ7K}dOwp^tzI t!!rWI7+w+>$M6Qje3q4(Zz0f%;XZ+O40ZzD7@Pzo4E-2hyYXLV{|l6QR}cUI literal 0 HcmV?d00001 diff --git a/src/wc_sdk/OPBROW.ICD b/src/wc_sdk/OPBROW.ICD new file mode 100644 index 0000000..f38d7c4 --- /dev/null +++ b/src/wc_sdk/OPBROW.ICD @@ -0,0 +1,65 @@ +Const + bcUpdate = ccUser0 - 1; + +Const + OpBrKeyMax = 220; + {-Last available slot in QkRefKeySet} +{--ID string for installation programs} + OpBrKeyID : string[12] = 'opBrows keys'; +{--Default key assignments} + OpBrKeySet : Array [0..OpBrKeyMax] Of Byte = ( + {length keys command type key sequence} + 3, $00, $00, ccQuit, {^Break} + 3, $00, $3B, ccHelp, {F1} + 3, $00, $47, ccHome, {Home} + 3, $00, $48, ccUp, {Up} + 3, $00, $49, ccPageUp, {PgUp} + 3, $00, $4B, ccLeft, {Left} + 3, $00, $4D, ccRight, {Right} + 3, $00, $4F, ccEnd, {End} + 3, $00, $50, ccDown, {Down} + 3, $00, $51, ccPageDn, {PgDn} + 3, $00, $76, ccEndOfFile, {^PgDn} + 3, $00, $84, ccTopOfFile, {^PgUp} + 2, $03, ccPageDn, {^C} + 2, $04, ccRight, {^D} + 2, $05, ccUp, {^E} + 2, $12, ccPageUp, {^R} + 2, $13, ccLeft, {^S} + 2, $17, ccUp, {^W} + 2, $18, ccDown, {^X} + 2, $1A, ccDown, {^Z} + 2, $1B, ccQuit, {Esc} + 3, $11, $12, ccTopOfFile, {^Q^R} + 3, $11, $03, ccEndOfFile, {^Q^C} + 3, $11, $04, ccEnd, {^Q^D} + 3, $11, $13, ccHome, {^Q^S} + 2, $0D, ccSelect, {Enter} + 2, $01, ccWordLeft, {^A} + 2, $06, ccWordRight, {^F} + 3, $00, $73, ccWordLeft, {^Left} + 3, $00, $74, ccWordRight, {^Right} + 2, $2B, bcUpdate, {+} + + {$IFDEF UseMouse} + 3, $00, $EF, ccMouseSel, {click left = mouse select} + 3, $00, $EE, ccQuit, {click right = ESC} + 3, $00, $ED, ccHelp, {click both = help} + {$ELSE} + 0, 0, 0, {110} + 0, 0, 0, 0, 0, 0, 0, 0, 0, {120} + {$ENDIF} + {-----------pad to End of array----------} + 0, 0, 0, 0, 0, 0, 0, 0, {130} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {140} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {150} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {160} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {170} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {180} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {190} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {200} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {210} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); {220} + +const + OPBrCfgEnd : Byte = 0; diff --git a/src/wc_sdk/QXINDEX.INT b/src/wc_sdk/QXINDEX.INT new file mode 100755 index 0000000..620e1ea --- /dev/null +++ b/src/wc_sdk/QXINDEX.INT @@ -0,0 +1,32 @@ +unit QXIndex; + +{$X+} + +interface + +const MaxKeyLength = 15; + +type TIndexKeyString = String[MaxKeyLength]; + + PIndexFile = ^TIndexFile; + TIndexFile = object + constructor Init(const fn: String); + destructor Done; virtual; + procedure Add(key: TIndexKeyString; x: Longint); + end; + + PIndexFinder = ^TIndexFinder; + TIndexFinder = object + constructor Init(aifile: PIndexFile; var akey: TIndexKeyString); + destructor Done; virtual; + function GetNextKey(var akey: TIndexKeyString): Boolean; + function GetNextRef(var n: Longint): Boolean; + end; + +type LockFileProc = function(var f: File): Boolean; + UnlockFileProc = procedure (var f: File); + +var QXLockFile: LockFileProc; + QXUnlockFile: UnlockFileProc; + +end. diff --git a/src/wc_sdk/QXINDEX.TPU b/src/wc_sdk/QXINDEX.TPU new file mode 100644 index 0000000000000000000000000000000000000000..c06f8c8bdffc59f7e2bbf151485cd49a48ca564a GIT binary patch literal 16800 zcmdUWd3;nwwtwBK+qZA8>4Xph#1IxEqGAFH2&imn79n&3VVQ>vNeB`M33e9t5C+k# z4vr%rqM`^WI4X_{4u}x~sL05o57c1*LB>pivJJ)%)4%Vjd%F{uaprwKzt8*QHJ(0o zmO6FLsj5?TZ`$#`v=oNVH*6aFhv)t9B@s_WY{b8v5kE$>ZL=XtcMoY3&8JyCtUGIK z;VfE<;cvL8$N%h8+)B-+7(}DmiYc4hZ{U1mDojzX%GN@&ClRM_&}Hli$r-|pP8lX< zth3o`oHb?A$lU2!^BG$+^eU4k$7$mhAXyrU}@)nm!jnr+-BggzR+Wnxzn9uH$UA@^kS-IfoE|pC| z$4XOb7$zxk1p5u6NZ(Xyq;V%Kl(0ZRdci!f8VztWlGaL%Ufd?5O;tzcW)~#tIxKH? zFs8Y5bTV`l_9uil1TLz>@^Z6MbPtqzICWFWFhE13iow&ThwIT05694kjb73|XB0E1 zAVD8iX25(UJSdlm^Erc2BFX*<+=!FrqX=ze!5NH`aj<>X9rW_Jw89zXn3JnoOSs*kd23iO+y<#hqomr0 zXB8x8%`d>bhU*E?@?s*5sJjY3LRDnc+HoFIP0gASuJ?m#QAjn}RHfWt)WeqS8JJGw zr-)|=@&`O?o3TQt_KLR!78)&0eCXQ+ zpm7x0Vk`>n7ogKs9C5b<_HnhnN-)PYx(>`}vZcZ!3KbwldTB69+ z3B?q9%A}x0a|kjDfiq=Niw!2L2qQBsMQgRCrD&bAo4rkB43upPScwtoD7N2XqZSpd zGicFPPNaQ^&-F!X7kU^)>zswL!Pv0NtutZVF% z)lh%OQf)z0_*7etf=*GVrx&DSoGl<}br35T(}vZy1#)5y;Xa3Nygw_;F!vM8Q7NL) zqqXzciWsd$Of13T7!7lu<}(Jv?xatV+&?X~Xr7j-m75xyv=eBhs5x0P3gAyPM5aF$ ztpAzhP_#BL$WwC=9x7He`cr)9>6+`$nvp%9;z7Mcp^DZvX|%{gQHFzcLOTctTknft z0ah5bjD7JQbbMN>Ixc%*R=7SB{UYI$vAq$NG>SzO-YV`9S?Q=xQC7-zIQto~bg|xU zrQq(jK4cw-NejgmWxd~eV{B1SA>QrQ6w7=wxF~e|rQo7qkb<*lDf&=<=J@oCoGe6& z9l>6M53NraIs(Wv#4`Wn{#xiDfVSg@=FLIg^7FH%w=9?+$beZnpoOIqG+<-2`e@v* zrGXR;r{LTIzo|rXZ%k(_^+CkrvT|l<8l$NtA?!HDq!(n)G>*v9O-Z3_rY%24+sElfYu~Jeaf-}`JPbKbL@V2LJ<`BbqkajqayST^LfT6(TPWgQI>xgcK#|kii;IP=SBOg80DxO<5hg8 zSfHAngJD+LtK~4@8HGdz>!_X5Qf&t-9ks;?mT_oc3iQFb)5oOe&(2@Q)*zjBc}p_p zkJ5|TG?4sGwT|_h%Im@C`|p(_({eM-J=l6?Uq;VGH}vF8PO6+cZu-Z6RwNWX3vMBR&(&uA35I~UmpgTAn z{5#1cV}4@F!=Im%Op2pFnE8b>a3kPnL(Ea`6rStn--H+#1ncyBx!kB1Xp!m9L_TPB z5l3U+BdREQH%QUalaY0W})3FxfosvcFh_KKSB`tbnF_wRC!$@%b(sM_P zFw+!DV|HA3jYRocj1eoSUlO)5Y(ILWD7o==T;W4`4jLyGDMN*3{Az$0G~*j!kjgy2 zBv~{)Z-rqp_ytKDAv0$6TnTHB+k_dNo$W<`itcoaL&P%25HwAV0pbJ~VgUvvn(8^l zKiT8;%x-P*ifOU8CzLN@U2l;%tt}EAw1_8i*lXou4Av<5xT3`(v4Tls>}^xuyp{~V zPI$!gt#r>6=9ofCasl=+(KIrB=rT)q1byM-GZ33=V!DFRr$l};R%+svCSD`&RE(`R zF;#o|yusvY#kLz{=vy~i@K1iCO&n+9?j}w!aX%9eGVvsNF=T9-Nzaty-f43021To{ zKj_}T_k*4Y+y}S>cn^za8-N!88ciIJty0VS(cFNyhV1~pmBq2Y0^g&YVm|9u2Z(;k9^gnZNZ~a9=$8ciE%H1G zcnRqF!1Ulx5B-GYqXqiVCz!1`Ns*n<`D_Jx3-F1uuQ>eI0_lMBPt!VEhc9R!eii>(bi2E{Vgjs^su*wiovWn9gM%0;MbWDhX6P*oxD9~=`JDUzo7 zA(_zxSNc9O!i?MusXZ{a#=^1wwbRT68GCPuk zL4$7LrK0p$dPAP7Qi$(h6cjxCh1Vq3O#NUgLLF3Hra)XlYz$Bb9jO4i}xH)yR%aj}%6w|T-Nx^f=wbn)=^E<91Y z-~nT?fZr)P>!EQ?W!*J8V60f9KPpbv&eN`=3vNQM4V^7f;A>bDcAJxqju?BcoDjP*h?hQNFV zZ;R7BiXG?ea1cl1d~MH?MMst)Vo-QuSe3X5=V2_nB08}cHI5BeJF^_M3tr3I%(koX zcwy6>HLADbjmuql&vG|AYUzX5CHLT+NPoOm7{D^Mfoz_3FDusuvrXC%JRT3j8-wBO zcIybdEf~qhSx2#ltjTz>Gae7z^H{*T06L5Cth)@)!^_xWK&8Hp?EoCm-^F9-yDSQD zi|rU59*^OX?jj!iF5;2yA|CxNELWqYLzIwJC5Zk&M@4* z!*J{E&JP0402%;xS9jjQ)q~&Rx{VKV-OrZ*Rsz<$2J>yMA$+%MDF57*#v|NmygQ&j zV3d0ze-PkzPvVccC-ZfHZGheG7x)ptYuqZncSqrNMe`CR8hDKGh0)wh6(wQqaj%&s z-U>?>`@=HCUQr}YhsEL&Ghej#ED%@3>!P=(6RsfJ#B9%-B1WwjD?BuBSMg@prGD!P zQ@^uX*-14FZ*|V*#B2ae&T%n<2j&&<8L8Fc5l!0YlhZ)?uJW07imN z20b2l9`GXOwictk4DEHSN_`hP$IvFY2)GQpUS%C0qrAf#m6Pf<X*ae;&yfEG@Jlt*d@Jb#5-S*&j z;3w5sKzBe7{+9JNzD4cBXIc6J_vIHvKmLk#5A^#34*(vB{sW;)a6j~iLT5N28S=4^ z`+!q`Q=yj%oixBi=uPGu#e>kB3VAwT!ZRSxfGmU0vS#wFd z5Bz-ee*yk%gpEzWo56n>*ewtfAVRFe{Liw+iIeJ7w5I~6i?^&9;)s|bHj0^$Ws6s| zT(N}b3AZ&5Iz`aI+iS5HvSQI$eMF>*70`VQyb7^JtprqoejM_Zz)y$*%Tti8hMhHH zmgQ;KS_@lifu9lm)n~zb4)T}KZzEt6`fNtuSAe%*yw@?_Hqh??wgcXSogL`A6E=22 zwo`27yD-Lwu(1cS8p!rSwikFG?0*FNA4B$M*!v9qzrYw@0=`1Ozkq)V{BMB21wM!I z>e2oI?Tct%Mf)e{HiEte+=TuCk%0oeMS=p4Iod+q%2i+sXiXg?tm-VQUG1z!scE8} zYD1mujH7Fc5(P{Ujdn-i7(gtb6Ce)tG7`1af%?}S^^fY_y{NN8fJdR`QQcbrScDo@ zj5=40x>t-kwgPqRQD9si_2*IRwxN#gL>+q{HSBA^N%X&n`bV|wD%wAyj{XST0E`Qz z?I+Z>M$p$#W3K@>0XKpFGrjaucG?tWwZ)=T16Er!U=7#`Y*h~0;?TZTISN>9=>gmW zyuPTBNy<6PaNq~PAB}oBRM}-+g*Mf~wZQApe;x3%z|R6dhrZ7NKM(voYUX;hH$%1= zwRAgR2kPlg@IClRo7nOymyS-@tI|9lV4#s=o z_VR^809yb$zzN#L&pAB2gEJg-1lkdNA!>6k?DK_6EXN!Hy7PdwC--SRf$!v*+MU1& ze4duTt1Str)d`>zK_~K~mPFL-yLqC1H){FasO5J<)`ypCeZcPnnxHS*efb$%UG z))%$DAI2oO2km=+`$N_rSK55UIlaCVG=JQ?z2=qE#;U@UlJ!5a(SSkOM``OwdYb_&j( z6yQ|oq(UbZz zL7s(kD+}jV7WgyKXD0M!p*;(DHpZIGE!u3HU$b$R<$%sXo^o)e;k}x54%&os`6ewF zwsN793mLWZ(9T0U5BBGRo{KRahVH}g{bA(fVVtLajN=F251m5j6vC$>@CfEXcOK?? z9%Kt3TL9TY@Cg<{wg~gTh&QTB;pbAE-x~p&xlP#&{4(&%IG4BZN_`9HEj$yDfpd3? zVilbM$-<5^*p9!cI)n&wi21^awo??_U7||3#H+v}%#HKb1MI=s8ZI($R_Cbgfn#7J z24{08oZFpne#Zg2;4JO}x(nn}#V+eK*vf*fEYTHp{HXmQ;B1`lvqZHWV3`HpY_w;K zqZWWY2WS2q&~re~fq%K87taMR7wtT>^TdX*JlM^{y&z8vcFYAm7y1MbqtC<8eHddG z!M7sOY+C^T7Q=@n@L>t!DHf9fR?kwjmx?)nOl>LX65K0(10KP0;RUq!JOcS6;)M1H z+AF|+6i|x(r5LLW?J~&A#5}DGcaw5)##RnqIe6uwTq{Q`6(Uiugsc)dC8z>j1-c4( zu7Y1HG4AhS`zgRGjJXQ^SE0QcW2{EJYY^`m=&S+%Y1n;Q1guZPpQj;P3)x!GYsJsn zTF}pceg-}~1Ku+jpYS^1b+Gp=`aTQ#S@b3R9C*)x_Z;ZwVEcK{&tshRXs-uXSPuV5}-$6UOQ zxp))n=pD?(yNLc>tf4=_?;Y@ahp5zdKz|45ouGG$$sU6D0oAzQeF)f%{OrcqyV2f* z{Oo~l4RmXuQ-k(iwD%&my~xL2(EC8|gTMR0+Xr6>?+4zG{vW~rk3fHf_z8au-pAm5 z4Eke?@d@Zp;Lic{KLGjwWCzgq0PdWhg7+zSpMv)(c%LFq2SFbMeGqv%h@AWxeGfzL zF!+bTKMcLY@bd`hBcP8UzehlS4*GM@pJNSD`wPVN1;#jzzQ;iyhwM1|9!E~Ugv~D@ z`w}_+3iMZKe}$;O2L2j8oP_>K=%0iSC*i{>{7T|1^8GFHUyuCPV_*IN-UZx~FTvI& z(3c^<4Ei#3u0r+`Y&SyI1o#=i)I?oTGlYU$7J&d*09JLlYR9e5r8e8b)M9%CZdnoP ztM)dycSiyfv{k);Z#_}!9D9^{LW@GXo$6!}c){afZSjhwh&$L_tS??;JMf|^34cy> zu;FYhi?TY{FlB_2fIrHNQj(Qbz*!<+5XKIc_+3#eafI4lC4TUeR`%_7&ejsSyq?z- zYw_hto^D|YXD#9EVTtDBo1n}_#1<>#fR z63&)=m{@&zQ-P9Pc45SAUj6Z}9^9?B>Qqyt#+N(2B|nKGzD*>Y-yR5@i7eX_U#@yf z|5AD_A#nIi@5k_vT7PpO?7`jF57%UjN29&EBM?aZxb(w*rwS~7b!h47p=X>JRmU5+ zc>=Ps<2MfcX6Fj8W~(mLO8)Mt@T!lV(yI$?C4bjT(J0WHKRI+Nzp?aC!dY|B>r$e} z2MRTS`W@aVd7IJV@qxQR#QIE^_9x+o0A(L0RF`+F7_XEs7KeT~{MF&(t-tk;;>#@Y zWobOVbctH>p;~$X!Pe0~-Ofr(dzil79{%Usd$^EozPr6?nUQ(-93{xw{ zYiI1}aO&`pL&v^pfI`sJB;jqg=xoH{@95v4PM9WS9B*jw3IXp$0Q6e36X1TpQUJZR z4L~6P1^Vel015#p1fURr0=?D^Kp_By02BgH2tXkKg#Z-jy)Qrk2!It32IvI1{{Y^7 z$lrm``$u|H8wVH!C;>>X{+AREv@Fb6EXu@cne8MVUzVf-G)z>vy3Nw9Q^Ayh$~Xm(%#tQZ5cfqOiV(Kv7D2%7a?@v-O;C-zJJfjDP{LceY5NTQ`b2DvM zRk;P1)vM|UCC2706tzbgwy!p^rr4=Xl=Ag>>+TKg!(SeTNXd4E`J|xS8+ef!{jeuQ z?Qe~qA-PntRTuEO`Ld&=TbP;u$s{`7U$v|GTGYhtO!d8Cj=KNRrfW!o8UU7NTT~LO zeTHYtcQsw}6rQNlgK^b(waVR8d+e>t2*r7wQ!J?e;3vi(ny`rFhgLt;I4xM?w8ZKS zjNau3afMf}m|zE^EUJZBQ|vJ_iG7Z;=50h;}S) zc;o{!p-3#)SYD=9iv$)#gEkS0u{23HSTo|UDAxMaED1(e=4~pQ&>Z3gikbsOO)~Bf zPg;{-Zg}boB{HNCD2fUcMPA>js<;VLqqb6~3`fXBMFtZUDXmr&H$YW4r!Zty+Plr$ z)Nw*{=#-GYwoaz(TUGph)I_*e=B>ZJx0&$}GtdWh2XLdS=pHDl|5t&z14Yj3wWZ7C zZAjf%I7S#FK{aP}%aYTF$|SvI&h9UQfk@hyfEC7rTl@ z?N()gx4|!JHz@nO-?32VKv6`X$aB4K|D5y+ZXT;Yp&~3?{~7&NVlc9@E&6;4ZuDs)COQ57IZZ{#{sqc zNHC45zU$+wn^~86gQfhAM!zzzr))yR3)oRGX>5kNzBlL=#hYVbszPJ@i;lG`TWuuF zH!TeJ4J*F#=;M1Tziz53zOc8*{p!FlKYt@^%M%IbFTeEo*CoXlSRt?L1sqnS?(<#< zgPL5~$mx%#L%Tf{DF+`*6Je&&1ky;(R@Li+L}LYFy)8qnpyh;eXr3xEI*`lut4y1? zJbs`@8|AF1)6=H6N!Bjv9(zUIMqb)D{^=H&#|$U+MiGU0Hm|5+^GV zwJ$L;R8w3ZUx7ofB29zEP-=*&$2*ejZ?HmTP<&|;f>WN?qFeYQ$V2zFI9T4z@7MgxB}D^U!rEs5=$^VoGfJ%ns8z`yiEwd3H>g` zS3sP`%e+_1CNz+~L6gL|dejtO#Vynduuv1`jCnQAkU&vGpy(&ZK)-IB4C`9I4YR@ZmR+{tLv&!<~CbrbQMAVK(vk`as+M!A)4kI1pPcR)< zTcrcpl{SreZweGOhJrT|9y)k~GtfF^!R29`AK|UekDvqv)2yB-l;(nX8tQVCiiTzT z=~RajRn?Z$r=?fLAyX)J-`E>B205-gz)i0aS`ytdtx^)2tL6l{84eBtpmcCso+dVskw@7EWKv- zjO|}l+<3z+$Jl1r2J?8RdHDZ(g&CvCsoDO2cIkw&+Iq3jhLt{qB>Q5Vj)rs1epF?}%`a{+{ zMnWBUUH4X*yS@$^8_!T}eeBYkfR?*2SLAdqtLM0{$}>vFj0^0WvU-**i4^(0@LbkR zS5Y%hvI~~C+gJ-BerWdV{NUleQDnl|)=xW{Xozo4ij?|vnF)0a~lIh1uIGKm5btKcD{LVq$~`znD+$@^LU%BnQfBfq6QSUBXHS6IHK6~%}5j}qX`Y#7Qxb|G#f@daG4A{|O>!zH?7M~rx zcS@Jr#lUIK!7;C$|LxE92M?a;@dwBIGpj~EySn(D+%KkHNp5prubwHfbKTDecKvYT zWYcFIKj{DZ5{d)I`~ zU(Wg1{nMSbA3a@LR{q}BSB6c>8lla& zf7I+pek5QC}WN#IX2=`7%BpbJfU zp{f5UXzKr@Nk3!Cp94Mx{yV_yfxiOo2S4zlEtC(khg`_<+M4ptro0_iZC1I}a)-z4B7&}$Ii0;%Vr|B+3~ z%cNY#k2wwblTseeo;T&&fa!%Rew~URvre3z>J6W#8Zss@fQj@R-7cluT7?|wL16~9CJNWSi_!>%;VcGmlf7FNhmZ1;0Gj5ZH!$UOh$$ZnTnc%*>}O|r66<&xH2Rm~ zFD2U{Uu)`Zm2$>*NzB=9lYh+Aua|s0ze}vKYrymZJDi8+fz5}#A#jQO8;$s?fipk{ z_bu%o{5(Ek8uzZ`s8-@gy_Gx*^qzn#ga{XGc!w7+RQ{Jzgz4@RCB zf~Gt_1^LU61EgQOOg+q#Twj%-qme%ZBQdShIOv}Mo(6mkdUJuJkT1f0kq`VoiR>X@ zn$LAIAB_D0@|lo-06xvb9+Q6vH2HBt(jNAA(B$t=n7=i^`166BKhBN$wwo9~N0j|K znsl6rZwH_H_vJ?adr1%e3^L_O6643__zM{MlMFfen`-hiOgz_=ZxW&PE$68x@^bxr8~I2>-YDKYU>f&vV9L`TbA2B&F7sjXGfX_!lovrx z^N0VXR_>pdfv3UlN5FBwG=HVQZOuFtnE83k#2bMJLB7+>=ULE`KsSLl>y@P2BhG2y z--SGm03HUKFQ9Ppot3bM~6a-v%5UkJiCd V(6r7oO#Co&BzVBrfxAom{{XoK{YL-* literal 0 HcmV?d00001 diff --git a/src/wc_sdk/README.1ST b/src/wc_sdk/README.1ST new file mode 100755 index 0000000..7e75895 --- /dev/null +++ b/src/wc_sdk/README.1ST @@ -0,0 +1,142 @@ +Version 4.10 +------------ + +New for version 4.10 is the ability to have multiple file databases and +CD-Rom groups, the WCFILEDB.PAS has changed slightly to handle the new multi +database scheme so your current programs will not compile with this release +without some minor changes. You will find all the new structures in WCTYPE.PAS +and a full explanation of the new file and group databases in WC40REC.DOC under +the file databases section. + +There has been a change in the way that WCFILEDB handles message bases that +are completely full, it will now return an error of 10666 meaning that the +message base is full and cannot accept any more messages, your software will +need to be able to deal with this situation when tossing messages into a +database. + +There is a new Serial define for OS/2 support in WCTYPE in the TInterface +enumberation. + +A new field has been added to TMakewildRec called GroupTable, this is used +by wcFILE to determine which drives to search for CD-ROMS. + +A new flag has been added to secprofiles called sfNoAuthWrite, if this flag +is turned on the user will not have access to the Write to Uploader feature. + +A new enumeration has been added to the TFileDisplay for the new Ansi file +lister. + +A new field has been added to TUserRec called DefaultGroup which is the +default group a user has selected, groups are ordered from 1 - HighGroup, +if the value is 0 then they have ALLFILES selected as their default and +65535 means all groups. + +A new flag is TMsgHeader (mfChgAttach) is used by wcFILE for charging a +file attached download. + +A new field has been added to TMenuCommand for the new select groups option. + + +We have included new versions of the following files. + +WCTYPE.PAS +WCMSGDB.PAS +WCFILEDB.PAS +WCUSERDB.PAS +WCDB.PAS + + +Contained in this archive are all the modules that someone needs to develop +third party applications for Wildcat! 4, the modules are written in +Turbo Pascal 7 and make extensive use of objects. We have provided units for +the user database, the file database and the message database, these are the +same units that we used in developing Wildcat! 4. We have also provided a unit +called WCMISC.PAS that contains a collection of various routines that will help +you in programming applications. Everything provided in the archive is identical +to what we use in Wildcat, we do not recommend that you write your own units +to handle the databases or that you change ours in any way. We will not help +you solve your programming problems if you discard our units and create your +own, we designed these units to be solid and easy to use and you will have +nothing but problems if you decide not to use them in your programs. You will +find examples on how to use all the objects and how to handle them, if you +need further assistance with objects we suggest you read the Borland language +guide for BP7. Since Wildcat 4's release a number of people have changed the +units because they thought they could get more speed by not using objects, +this is simply not true, there is not speed loss by using objects code over +procedural code. In fact if you pass around a pointer for your procedural +routines you are doing the same amount of work an object does, which is very +minimal. + + +Version 4.01 +------------ + +New for version 4.01 of Wildcat is a locking scheme that allows wcPACK to +run while Wildcat is online, this is described in the WCMSGDB.DOC file. +We have also provided a new unit called WCMSGEX.PAS that goes along with +the new locking code. + +You will need at least version 4.51 or greater of Btree Filer by +TurboPower Software, they can be reached at the following address: + +TurboPower Software +1065 Eckton Drive +Colorado Springs, Co 80907 + +Voice - 800-333-4160 +Fax - 719-260-7151 +BBS - 719-260-9726 + +You must have 4.51 or later of the Btree Filer or the modules will not +compile, we also do not suggest that you attempt to re-fit the units to +work with earlier versions as we now take advantage of 4.5x specific +routines. We also do not recommend making changes to the units as we have used +and developed with them for over a year and they are quite sound, if you need +to write your own special routines you should take advantage of the fact that +all three databases are designed as objects and you can inherit their features +and write your own wrapper routines. + +The programming staff is always happy to answer questions about problems you +may encounter while developing your applications, we ask that you please use +the MSI-HQ BBS (805)-873-2400 for these types of questions, it much easier for +us to answer your question on the BBS. + +Notes for developing +-------------------- +The modules that make up the archive are as follows: + +WC40REC.DOC Contains the technical documentation on Wildcat! 4. +WCUSERDB.DOC Contains technical information on the user database. +WCMSGDB.DOC Contains technical information of the flat file system. +WCDOORS.DOC Contains technical information on the door files that + Wildcat creates when running doors and external programs. +QXINDEX.INT Contains the object definitions for using the Quick Indexer. +QXINDEX.TPU Contains the compiled code for the Indexer. +QXSTUB.PAS Contains two routines that the indexer needs to run, MAKE SURE + that if you use the indexer routines you include this file. +SAMPLE.PAS Contains an example of how to look up a users message links. +MSGCHECK.PAS Contains an example of how to check for high message numbers. +LISTFILE.PAS Contains an example of listing adding the file database and + an example of using the Indexer. +SEARCH.PAS Contains a detailed example of how to use the Indexer. +WCTYPE.PAS Contains all the structure and type defines used in Wildcat! 4. +WCMISC.PAS Contains assorted routines for the example programs. +WCGLOBAL.PAS Contains global structures used by the example programs. +WCDB.PAS Contains the root database object used by the file and user + database. +WCFILEDB.PAS Contains the objects for accessing the file database. +WCUSERDB.PAS Contains the objects for accessing the user database as well + as the CONFDESC.DAT file. +WCMSGDB.PAS Contains the object for accessing the flat file message database. +WCMSGEX.PAS Contains the object for accessing the external message file. +WCSTRING.H Contains 'C' string declarations +WCTYPE.C Same as WCTYPE.PAS except for 'C' compilers +WCTYPE.H Contains global structure definitions for WCTYPE.C + +For information on using the Indexer see the SEARCH.PAS unit, it gives full +details on how to set it up and how to use it in your code. + +At this time the only C code we have available is the (C Units), we do not +have any specific C code for accessing the databases, you can purchase a C +version of BTree Filer and we have designed the databases so that they use +C Style keys to make it easier on everyone. diff --git a/src/wc_sdk/TURBO.DSK b/src/wc_sdk/TURBO.DSK new file mode 100755 index 0000000000000000000000000000000000000000..6a757bea0fdb71719797455767565de46c790dd9 GIT binary patch literal 1391 zcmb`H%Wl&^6o&tab7@1kq^SeyqIHS8F;Xfd*aTSAaSQ>sF>#v8G>y6q9R4t>b8BNtOcUNVAKR+_q^+w)wePMW@1X zF!`7I68~5XxXDx8SchQ0oLY8P~{VV{UANVIL$$Kf!H8Vu~9J zGB-v$=Efr2$aa$3C=!oz%lskUDi7`dOfCIeY9;y{F+3^L)NX`j>KR8{8rR8Xo2GUk zG585;BMwv4cpi7K!jRf`?F~8J>_ayhJn;U04ZvHS2~^_3*%cXSeFjpyQB#g>p3CXmx5{f~q$u$Map^uQdas?!P4W e9i6n;@CLm~5^t$3cB|eATK+Sbx^CSjFuwpN`^{Yd literal 0 HcmV?d00001 diff --git a/src/wc_sdk/TURBO.TP b/src/wc_sdk/TURBO.TP new file mode 100755 index 0000000000000000000000000000000000000000..7f9d4ab202b056d13c7f6ae930599df18410507f GIT binary patch literal 4034 zcmeH~QEXG!8OOiR-$|~s5KQ7gLbAk$xFg&^664gz$%sv2lE5I2v7NZAp_N1I&cZks zCt+r7u~vzPJ#5o7Roz}HP+!)E@xlw8)M=uXR%s7YOFQ(A0QNZpC z1p4fNZB0)mQ$O_(eG~k{cGLdj%+2;-aw7e0d+=l;PG297wF2&kX1j=S!e%8?iRsgs z)I+_G)7TkE%%!svN&nDPGCh}g99P?Onf_@rwYc5c2BKqIw(D+uZEVBiyZ@?rXk8v# zTyqu+_<2+o*UQDV)vsEFU&r%*zXJTkGyIo*s-3J6Y*}f zgF}y$F|s`02nNx=?ceuE|4=L%^VNJ^(WrOqhT~LgmgT|eIF|Ee>C|dyTAu9^YI!_W zPZjFHAZL55RmGLI<{5*>GRFfyj^n9T5y6A@|1M307zmG#_M6KXm(UvyoNoI!SN(FN zF(E?Z0VUj+VIDIFR`W60{CE7ehle9{oF@>WWzl^*+R%zSwK?j)tJUkDgTK|mCMl}d z@1uIZK0*@|;W6^No~18bZPZOig{dGyIZ>3521-dI6~&^mxTz#f)Tf$hTz1e;)K2m# z55;8{y{ua4n6%NNcqu9Ev?hD#ZPh_%rIRwUmmKM$1?kd1mLB~x>DI5y?QlsVx+I^3 zlX5SdkUxb}^5<|yJ`69)N8y~@4PTLu!nWBrPJq_4?` z`ZXDak9Wd-YF@u7S^Y~{&~M3e`d5OC-aeaBpdmyq$7WkOyr)VP@X|~M*mt; z`j)()|DZnAe^lr6UGXT0 zfm8H%xd58MY1)ty*a4FC3*~@a;0)$p0<9oL*Hi_xfizuLtH28~^o6W}b}&ypY8~tb z3)HSIgFPTiKUCib9pEf=sw-eG7^Y`bkowgT8c-n`R3j8r&(eqrlUAC>RD{OWC>>K1 z^mCO13?`|Loa@NBj-0Q_c_838U6Ey=z!beAdC&l+=|`#n8o?yZv z0&=*3931sLt*dTuj;g8$Ow(<|bsKTr#=hLdzTCvV+*EV)d$j^QAVqhu=6A5>cd*Xy zsx{CK=IIvJ`4-msmSPvP%f&9?Hg07vw{wQ)c{lIjz2n?9&Y|dnku0QxL!Eq(`}rCE z79ZeH4~Kd=eSvPSgOmGrrBQ7IiL>Xx?(rCmo;x^I*InAM2 z9%VVW$+8TlHaR4Rj7%Gufhi7-fmvfXyvcpiyU8;~P8vxWNg6q8L|y`Z-~;1Uaw-G_XN&ld0dfu~CDA5IRWwJe?zcnO-G6N>QTyIOzaR*VaAL zzTshNzaKzdh*WR`HiUVE5sXIndYFb^xtiTes*ZC~XIjz*F!lPsOWxDqiu& z_rzC#s1a{!Zu%>nZ(!pZ<13|=%IXIeUWZ`X5ns7@F;`yB13#nM$s_TF6&udUEpg8+aA} EHx5_Y9smFU literal 0 HcmV?d00001 diff --git a/src/wc_sdk/USERREC.CPP b/src/wc_sdk/USERREC.CPP new file mode 100755 index 0000000..7c2df94 --- /dev/null +++ b/src/wc_sdk/USERREC.CPP @@ -0,0 +1,117 @@ +#include +#include +#include +#include + +#include "wctype.h" + +char *LengthByteToNull(char *s, int maxlen) +{ + int lenbyte; + + lenbyte = s[0]; + assert(lenbyte < maxlen); + + memmove(&s[0], &s[1], lenbyte); + memset(&s[lenbyte], 0, maxlen - lenbyte); + + return s; +} + +char *NullToLengthByte(char *s, int maxlen) +{ + int lenbyte = strlen(s); + assert(lenbyte < maxlen); + + memmove(&s[1], &s[0], lenbyte); + s[0] = lenbyte; + memset(&s[lenbyte + 1], 0, maxlen - lenbyte - 1); + + return s; +} + +void ConvertUserFromPascal(TUserRec &user) +{ + LengthByteToNull(user.UserName, sizeof(user.UserName)); + LengthByteToNull(user.From, sizeof(user.From)); + LengthByteToNull(user.Password, sizeof(user.Password)); + LengthByteToNull(user.PhoneNumber, sizeof(user.PhoneNumber)); + LengthByteToNull(user.DataNumber, sizeof(user.DataNumber)); + LengthByteToNull(user.FaxNumber, sizeof(user.FaxNumber)); + LengthByteToNull(user.ComputerType, sizeof(user.ComputerType)); + LengthByteToNull(user.SecLevel, sizeof(user.SecLevel)); + LengthByteToNull(user.Secondary[0], sizeof(user.Secondary[0])); + LengthByteToNull(user.Secondary[1], sizeof(user.Secondary[1])); + LengthByteToNull(user.Secondary[2], sizeof(user.Secondary[2])); + LengthByteToNull(user.Secondary[3], sizeof(user.Secondary[3])); + LengthByteToNull(user.Secondary[4], sizeof(user.Secondary[4])); + LengthByteToNull(user.Company, sizeof(user.Company)); + LengthByteToNull(user.Address1, sizeof(user.Address1)); + LengthByteToNull(user.Address2, sizeof(user.Address2)); + LengthByteToNull(user.City, sizeof(user.City)); + LengthByteToNull(user.State, sizeof(user.State)); + LengthByteToNull(user.Zip, sizeof(user.Zip)); + LengthByteToNull(user.Country, sizeof(user.Country)); + LengthByteToNull(user.Title, sizeof(user.Title)); + LengthByteToNull(user.Alias, sizeof(user.Alias)); + LengthByteToNull(user.NovellName, sizeof(user.NovellName)); + LengthByteToNull(user.Language, sizeof(user.Language)); + LengthByteToNull(user.Comment[0], sizeof(user.Comment[0])); + LengthByteToNull(user.Comment[1], sizeof(user.Comment[1])); + LengthByteToNull(user.Comment[2], sizeof(user.Comment[2])); + LengthByteToNull(user.Comment[3], sizeof(user.Comment[3])); + LengthByteToNull(user.Comment[4], sizeof(user.Comment[4])); +} + +void ConvertUserToPascal(TUserRec &user) +{ + NullToLengthByte(user.UserName, sizeof(user.UserName)); + NullToLengthByte(user.From, sizeof(user.From)); + NullToLengthByte(user.Password, sizeof(user.Password)); + NullToLengthByte(user.PhoneNumber, sizeof(user.PhoneNumber)); + NullToLengthByte(user.DataNumber, sizeof(user.DataNumber)); + NullToLengthByte(user.FaxNumber, sizeof(user.FaxNumber)); + NullToLengthByte(user.ComputerType, sizeof(user.ComputerType)); + NullToLengthByte(user.SecLevel, sizeof(user.SecLevel)); + NullToLengthByte(user.Secondary[0], sizeof(user.Secondary[0])); + NullToLengthByte(user.Secondary[1], sizeof(user.Secondary[1])); + NullToLengthByte(user.Secondary[2], sizeof(user.Secondary[2])); + NullToLengthByte(user.Secondary[3], sizeof(user.Secondary[3])); + NullToLengthByte(user.Secondary[4], sizeof(user.Secondary[4])); + NullToLengthByte(user.Company, sizeof(user.Company)); + NullToLengthByte(user.Address1, sizeof(user.Address1)); + NullToLengthByte(user.Address2, sizeof(user.Address2)); + NullToLengthByte(user.City, sizeof(user.City)); + NullToLengthByte(user.State, sizeof(user.State)); + NullToLengthByte(user.Zip, sizeof(user.Zip)); + NullToLengthByte(user.Country, sizeof(user.Country)); + NullToLengthByte(user.Title, sizeof(user.Title)); + NullToLengthByte(user.Alias, sizeof(user.Alias)); + NullToLengthByte(user.NovellName, sizeof(user.NovellName)); + NullToLengthByte(user.Language, sizeof(user.Language)); + NullToLengthByte(user.Comment[0], sizeof(user.Comment[0])); + NullToLengthByte(user.Comment[1], sizeof(user.Comment[1])); + NullToLengthByte(user.Comment[2], sizeof(user.Comment[2])); + NullToLengthByte(user.Comment[3], sizeof(user.Comment[3])); + NullToLengthByte(user.Comment[4], sizeof(user.Comment[4])); +} + +void main() +{ + FILE *fp; + TUserRec userrec; + + fp = fopen("userrec.bin", "rb"); + fread(&userrec, sizeof(TUserRec), 1, fp); + fclose(fp); + + ConvertUserFromPascal(userrec); + + // Do something with userrec + + ConvertUserToPascal(userrec); + + fp = fopen("userrec.bin", "wb"); + fwrite(&userrec, sizeof(TUserRec), 1, fp); + fclose(fp); +} diff --git a/src/wc_sdk/WC40REC.DOC b/src/wc_sdk/WC40REC.DOC new file mode 100755 index 0000000..39cc023 --- /dev/null +++ b/src/wc_sdk/WC40REC.DOC @@ -0,0 +1,575 @@ +Setting Up Filer +---------------- + +When setting up Filer to work with Wildcat you will need to modify the +FILER.CFG to reflect a MaximumKeyLength of 35, you will also need to make +sure that the BTDEFINE.INC file has the network types enabled and is set +to NOT use Ems. + +General Routines +---------------- +With the release of 4.0 we have made changes to help support those people +who want to program in other languages like C. You will find both source +for Pascal and C, This also means that when you create keys for the Wildcat! 4 +databases you must first pack them using the standard WordToKey routine +(or LongToKey) and then call the Filer routine CStyleNumKey. This +strips all the nulls from the key and makes it ascii compliant. +Here are the two routines used in the database modules: + + +function Word2Key(Num : Word) : String; +begin + Word2Key := CStyleNumKey(WordToKey(Num)); +end; + +function Long2Key(Num : LongInt) : String; +begin + Long2Key := CStyleNumKey(LongToKey(Num)); +end; + + +If you need to do a KeyToWord (or KeyToLong) first call the PascalStyleNumKey +routine and then call KeyToWord. + +*** READ THE FOLLOWING *** + +You will want to add a two lines of code to the CStyleNumKey and the +PascalStyleNumKey to fix a problem with the Btree Filer 5.41 routines, +In the CStyleNumKeys add this line: + + +OrigLen := Length(S); +if (OrigLen = 0) or (OrigLen > MaxInpStrLen) then begin + CStyleNumKey := ''; + Exit; +end; +S[OrigLen+1] := #0; <---- Add This Line + + +And in the PascalStyleNumKeys add the same line: + + +OrigLen := Length(S); +if OrigLen = 0 then begin + PascalStyleNumKey := ''; + Exit; +end; +S[OrigLen+1] := #0; <---- Add This Line + + +During the development of Wildcat 4.01 we found a problem in the filer +routines that would cause various database errors under extreme conditions, +the database routines would report 10010 errors on a regular basis, the +problem is with the ISAMOPENFILEBLOCK routine in ISAMLOW.INC. You will need +to make the following changes in order to prevent the errors, you must also +make sure that your filer.cfg is set to 250 for maximum number of workstations, +if you do not set this correctly then you will have problems with the open +routines. Here are the following changes to the ISAMLOW.INC module in the +ISAMOPENFILEBLOCK routine: + +On line 1166: + + If Level >= 2 Then Begin + If UseLock Then Dummy := IsamUnLockRecord ( 3, 1+IsamNrOfWs, DiaFile.Handle ); + End; + +On line 1271 + + If UseLock Then Begin + If Not IsamLockRecord ( 3, 1+IsamNrOfWs, DiaFile.Handle, + IsamLockTimeOut * IsamFBLockTimeOutFactor, + IsamDelayBetwLocks ) Then Begin + UnDo ( 1, 10355 ); + Exit; + End; + End; + +On line 1401 + + If UseLock Then Begin + If Not IsamUnLockRecord ( 3, 1+IsamNrOfWs, TIFBPtr^.DiaF.Handle ) Then Begin + UnDo ( 4, 10342 ); + Exit; + End; + End; + + +Comment out the following pieces of code: + +Starting at line 1350 + +(* + If UseLock Then Begin + If Not IsamLockRecord ( 3 + FlagSetLen, IsamNrOfWS * FlagSetLen, + TIFBPtr^.DiaF.Handle, 0, 0 ) Then Begin + UnDo ( 4, 10355 ); + Exit; + End; + End; +*) + + +Starting at line 1394 + +(* + If UseLock Then Begin + Dummy := IsamUnLockRecord ( 3 + FlagSetLen, + IsamNrOfWS * FlagSetLen, TIFBPtr^.DiaF.Handle ); + End; +*) + +Conference Groups +----------------- + +In version 4.12 of Wildcat! we have added the ability to have Conference +Groups, these are handled by the file CONFGRPS.DAT which contains all the +settings for the conference groups. There are two structures associated with +Conference groups, the first is the TConfGroup file which contains the Name, +Flags and Display file for the group, the conf groups are stored the same +way that we store the confdesc files with the TConfGroup followed by a set +of bits for the conferences in this group. To get more information on how +this works see the discussion below on the ConfDesc file. + +Conference groups are pretty simple to handle, Makewild does no collision +checking so a conference can be a part of multiple groups all at the same +time, when a user selects a group in Wildcat!, the program will list all the +conferences selected for that conference group that the user has access to. +Wildcat! also checks to make sure that the user has access to at least one +conference in the group before allowing the user to select the group. + +Makewild also maintains a CONFGRPS.IX and .UX file, the UX is an unsorted +listing of the Groups using the TConfGroupList structure, the IX file is +the sorted version of the conference groups. You can accomplish sorting by +using the MSort option in Turbo Power's BTree kit. + + +WcDial files +------------ + +The 4.12 release of Wildcat! contains a new feature called wcNET that allows +two Wildcat! nodes to dial up and transfers files back and forth using +scheduled events. There are two files maintained by Wildcat! for the wcNET +they are as follows: + +WCDIAL.DAT + +This is the main file used by Wildcat! the 0 Record in this file is the +structure TDialMaster and is used to store all the global variables that +wcNET needs for this node, it is then followed by the TDialNode records +which are the hosts that this node will be dialing, please note that the +TimeLimit field is not being used at the moment but is reserved for future +use. + +WCDIALIN.DAT + +This is the file that wcNET uses to lookup an incoming node, it consists of +TDialNode records only. + +For a more in depth discussion of wcNET please see the WCNET.DOC file +included in the WC40REC release. + + +File Database +------------- + +New to version 4.10 is the ability to have multiple file databases, there +are minor structure changes to the TFileAreaRec so that it now inlcudes a +field for the name of the Database associated with this area, if the field +is left blank it is considered part of the default ALLFILES database. Wildcat! +will look at this field anytime an area changes and open that database, all the +databases are stored in the FileDataBasePath stored in Makewild. When opening +a database you must specify both the path and the database name, the init +routines will create a database that does not exist as long as the path is +valid. We have also added a file called GROUPS.DAT that contains all the +information about the Groups and the databases that are associated with them. +Groups are stored in the same fashion as conferences, where you have a Group +record and then a Bitset that's size depends on the amount of file areas +currently on the system (see the discussion on the CONFDESC.DAT file for more +information on how to handle the on disk bit sets). Wildcat uses the GROUPS.DAT +file to search for specific files on the system, since it provides all the +file databases currently available, so if a user types in a filename, Wildcat +will search the ALLFILES.DAT database first and then go through each group +opening that database and searching it until it either finds the file or +reaches the end of the GROUPS.DAT file. No other part of the file old file +database structures have changed at all. + +The TGroupHeader structure is used as the record type for the GROUPS.DAT file, +the layout of the file is TGroupHeader followed by a bitset of the current file +areas available to this group. In the TGroupHeader are two fields called +FirstArea and LastArea. These are the starting and ending areas for this group. +They are not inclusive however and only provide a shortcut when reading the +Filearea bits. Even with these fields you still need to check the bits as +it is possible to have areas from other groups in the middle of these two +fields. The FileDatabase field of the TGroupHeader is the name of this groups database that is stored in +the FileDataBasePath. gFlags is the flags that control what options each group +has available, if a record has the grGroupHidden flag set Wildcat will not touch +it except in the sysop area, the same applys to Groups that do not have any +areas selected. The grSendMsg flag is used for sending messages to the sysop +when a user makes a request for this group, grGroupOnline flag determines +whether this CD-ROM is mounted and available. The grRequest is whether this Group +can make file requests or not. The VolumeID is the Volume Name of the CD-ROM +associated with this group, the VolumeFile is a unique file that wcFILE will +look for if the CD-ROM does not have a unique Volume Name. Neither the VolumeID +of VolumeFile fields are used if the grFixedDevice flag is turned on. The +Location field points to the physical location of the group if the grGroupOnline +flag is set. If the grGroupOnline flag is NOT set, the location field is not +guaranteed to be correct. The last part +of the TGroupHeader is the LockedCount, Wildcat uses this so that if it is +copying or downloading from a Group it will Increment this number and when +finished will decrement it, wcFILE checks to see if the Group is in use when a +User requests that a group be taken offline. The TGroupList record is used for +the sorted (IX) and unsorted (UX) GROUPS files. + +The TCDRequest is the file Wildcat creates when a user requests a file that +is part of an offline Group. The record is filled out with the current +information and attached to the REQUESTS.DAT file, wcFILE then picks up the +requests and processes them by sending a message to the user with the file +attached to it. wcFILE also sets mfChgAttach flag in the message header when +leaving an attachmen. This flag tells Wildcat to charge the user for this download +when the user receieves the file. + +Drop in Databases are comprised of three files, +1) the DataBaseName.DAT file which is the BTree Database of all the files contained + in this Drop in. This file has the same structure as the ALLFILES database. + The IX and QX files are not supplied with Dropin databases. +2) The DataBaseName.ARE is a flat file of TGroupDesc that contains all the + information on the file areas associated with this Drop in. +3) DataBaseName.CFG which is the TGroupHeader for this Drop in Group. + +wcFILE creates these three file and archives them with PKZIP2 and puts an +extension of .DRP on the filename, when creating a Drop in database file +you must fill out the TGroupDesc with the current information from Wilcat, +the AreaName, AreaPath and AreaNumber should all come from the TFileAreaRec. +Zero out the NewArea field as it is used only by wcFILE. + +The main file database is a Btree Filer database with four keys. There +is also a secondary index file that is not generated with Filer to +support fast searching of the file database. This secondary index will +be documented in later versions of this file. This Filer database is a +variable record sized Filer database. The section size of this +database is 291 bytes, this is the number that must be passed to +BtCreateFileBlock when creating a file database. The extended +description of a file is an array of characters layed out in the +following format: 1) There is a line length limit of 79 characters, +each line is ended with a CR character making the length of a full line +80 bytes. 2) There may be up to 15 lines in the extended description, +adding more lines will corrupt the database and possibly corrupt memory +inside of Wildcat causing a crash. There is no ^Z terminator at the +end of the description as there was in previous versions of Wildcat. +The MsgBytes field in the TFileRec should be set to the total number of +bytes in the array including the end of line characters. Here is a +list of the keys and the IsamIndDescr structure you pass to +BtCreateFileBlock when creating the database: + +const + FileAreaKey = 1; + FileNameKey = 2; + FileDateKey = 3; + FileUpKey = 4; + +IID is a variable of type IsamIndDescr that is passed to BtCreateFileBlock. + +DataLen := 316; +Keys := 4; +IID[FileAreaKey].KeyL := 15; +IID[FileAreaKey].AllowDupK := False; +IID[FileNameKey].KeyL := 15; +IID[FileNameKey].AllowDupK := False; +IID[FileDateKey].KeyL := 12; +IID[FileDateKey].AllowDupK := True; +IID[FileUpKey].KeyL := 30; +IID[FileUpKey].AllowDupK := True; + +Here is a sample routine to create the keys for a file record in the +file database: + +function BuildKey(const FileRec : TFileRec; Key : Integer) : IsamKeyStr; +begin + with FileRec do + case Key of + FileAreaKey : BuildKey := Word2Key(Area)+StUpcase(Pad(FileName, 12)); + FileNameKey : BuildKey := StUpcase(Pad(FileName, 12))+Word2Key(Area); + FileDateKey : BuildKey := Word2Key(Area)+Word2Key(FileTime.D)+Long2Key(FileTime.T); + FileUpKey : BuildKey := Pad(StUpCase(Uploader), 25)+Long2Key(UploaderId); + end; +end; + + +User Database +------------- + +The main user database is a Btree Filer database with six keys. The username +key is no longer unique as we are now allowing users with duplicate names +to be in the database, there are now two unique keys, the users alias and the +users ID. The user database stores the highest user number in the MasterInfo +record of NODEINFO.DAT (record 0), the database also verifies the number by +comparing the highest user ID key with the number in MasterInfo. Here is the +layout for the new user database: + +UserNameKey = 1; +UserSecKey = 2; +UserExpDateKey = 3; +UserAliasKey = 4; +UserIdKey = 5; +UserRealKey = 6; + +IID is a variable of type IsamIndDescr that is passed to BtCreateFileBlock. + +DataLen := SizeOf(TUserRec); +Keys := 6; +IID[1].KeyL := 30; {UserName + UserID Key} +IID[1].AllowDupK := False; +IID[2].KeyL := 35; {SecLevel + UserName Key} +IID[2].AllowDupK := True; +IID[3].KeyL := 3; {Expired Date Key} +IID[3].AllowDupK := True; +IID[4].KeyL := 25; {User Alias Key} +IID[4].AllowDupK := False; +IID[5].KeyL := 5; {User ID Key} +IID[5].AllowDupK := False; +IID[6].KeyL := 25; {User Real Name} +IID[6].AllowDupK := True; + + +Here is a sample routine to create the keys for a user record in the +user database: + +function SwitchLast(const Name : Str25) : Str25; +var + X, Y : Byte; + +begin + Y := Length(Name); + X := Y; + while (Y > 0) and (Name[Y] <> ' ') do + Dec(Y); + if Y = 0 then + SwitchLast := Name + else + SwitchLast := Copy(Name, Succ(Y), X - Y) + ' ' + Copy(Name, 1, Pred(Y)); +end; + +function BuildUserNameKey(const Name : String; UserID : LongInt) : IsamKeyStr; +begin + BuildUserNameKey := Pad(StUpCase(SwitchLast(Name)), 25)+Long2Key(UserID); +end; + + +function BuildUserIDKey(IDName : LongInt) : IsamKeyStr; +begin + BuildUserIDKey := Long2Key(IDName); +end; + + +function TUserDatabase.BuildKey(const Data; Key : Integer) : IsamKeyStr; +var + UserRec : TUserRec absolute Data; + +begin + with UserRec do + case Key of + 1 : BuildKey := BuildUserNameKey(UserName, UserID); + 2 : BuildKey := Pad(SecLevel, 10)+StUpCase(SwitchLast(UserName)); + 3 : BuildKey := Word2Key(ExpireDate); + 4 : if UserRec.Alias = '' then + BuildKey := '' + else + BuildKey := StUpCase(Alias); + 5 : BuildKey := BuildUserIDKey(UserId); + 6 : BuildKey := StUpCase(UserName); + end; +end; + + +function TUserDatabase.AddRecord(var RefNr : LongInt; var Data) : Boolean; +var + UserRec : TUserRec absolute Data; + ConfPage : TUserConfPage; + RefKey : IsamKeyStr; + UserRef : LongInt; + +begin + AddRecord := False; + Lock; + if MwConfig.DupUserLevel <> duAllow then + if FindKey(UserRealKey, RefNr, BuildKey(UserRec, UserRealKey)) then + begin + Unlock; + Exit; + end; + Unlock; + ReadMInfo(True); + ClearKey(UserIDKey); + PrevKey(UserIDKey, UserRef, RefKey); + if IsamOk then + UserRef := Key2Long(RefKey) + else + UserRef := 0; + if UserRef > MInfo.HighestUserId then + MInfo.HighestUserId := UserRef + 1 + else + Inc(MInfo.HighestUserId); + WriteMInfo; + Lock; + (* + we now have to recheck the duplicate situation, in weird cases we make + increment the highest user id without adding a new user but this is + required to prevent deadlock situations + *) + if MwConfig.DupUserLevel <> duAllow then + if FindKey(UserRealKey, RefNr, BuildKey(UserRec, UserRealKey)) then + begin + Unlock; + Exit; + end; + UserRec.UserId := MInfo.HighestUserId; + UserRec.UserConfData := 0; + if inherited AddRecord(RefNr, Data) then + begin + AddRecord := True; + UserConfDb.GetPage(UserRec, 0, ConfPage); + end; + Unlock; +end; + + +Security Profiles +----------------- + +Wildcat 4.0 adds support for up to 32,760 conferences and 32,760 file +areas, as a result of this certain fields in the security profiles are +now variable sized. Also when a Wildcat is configured for a large +number of conferences or file areas the data structures for these +variable sized pieces of the security profile can get so large that it +is not possible to keep them in memory all at once. If your program +must conserve memory we recommend using a paging scheme to only keep +part of the variable sized data in memory at once. Wildcat uses a +scheme like this in which Wildcat only uses 2K to access 24K of data +that will exist in the worst case system. There are also two types of +security profiles, Primary and Secondary. Primary profiles are the +ones you edit and use to set a users options, the secondary is used for +setting a users access to certain areas, specifically those with bit +access. What Wildcat does is load the users primary profile and then +load each secondary and logically OR the bits for doors, nodes, +protocols and menu items, then it pages the conf/file bits and OR's +those with the primary file and when it is finished it writes the new +profile to the users wcwork/node directory where Wildcat uses it to +determine file and conference access. Use the TSec header to determine +what type of profile you are looking at. + +Here is the layout of the security records in the SECLEVEL.DAT: + +/* First record */ +TSecRec record from WCTYPE.PAS +((Number of conferences * 3) - 1) div 8 + 1 of bytes of conference security info +((Number of file areas * 3) - 1) div 8 + 1 of bytes of conference security info + +/* Second record */ +TSecRec record from WCTYPE.PAS +((Number of conferences * 3) - 1) div 8 + 1 of bytes of file area security info +((Number of file areas * 3) - 1) div 8 + 1 of bytes of file area security info + +And so on.... + +To compute the exact size of a record in the system you would do something +like this: + +function SecRecSize : LongInt; +var + FileBitSize, + ConfBitSize : LongInt; + +begin + ConfBitSize := ((LongInt(Number of conferences) * 3) - 1) div 8 + 1; + FileBitSize := ((LongInt(Number of file areas) * 3) - 1) div 8 + 1; + SecRecSize := LongInt(SizeOf(TSecRec)) + ConfBitSize + FileBitSize; +end; + +What do the security bits mean? +------------------------------- + +sConfRead = $01; {The first bit gives the user access to read messages in the conference} +sConfWrite = $02; {The second bit gives the user access to write messages in the conference} +sConfJoin = $04; {The third bit gives the user access to join the conference} + +function GetConfAccess(Conf : Word) : Byte; +begin + I := Conf * 3; + GetConfAccess := (Word((address of conf data[I div 8])^) shr (I mod 8)) and $07; +end; + +The above function will return the bits for the specified conference if you +point the function at where you load the conference data into memory. You +can then test for various options using the and operator like this: + +if (GetConfAccess(9) and sConfRead = sConfRead) then begin + {user has conference read access in conference 9} +end; + +sFileList = $01; {The first bit gives the user access list files in the area} +sFileDown = $02; {The second bit gives the user access to download files in the area} +sFileUp = $04; {The third bit gives the user access to upload files in the area} + +function GetFileAccess(Area : Word) : Byte; +begin + I := (Area - 1) * 3; + {!! It is important to notice that we decrement the file area, this !!} + {!! is because file areas are numbered starting at 1, we decrement !!} + {!! the area so we don't skip the first three bits in the data !!} + {!! structure. !!} + GetAreaAccess := (Word((address of file data[I div 8])^) shr (I mod 8)) and $07; +end; + +The above function will return the bits for the specified file area if you +point the function at where you load the file data into memory. You +can then test for various options using the and operator like this: + +if (GetFileAccess(7) and sFileList = sFileList) then begin + {user has file list access in file area 7} +end; + +Conference Definition Records +----------------------------- + +The conference records in Wildcat 4.0 are also variable sized for the same +reasons metioned in the section on Security Profiles. The layout of the +conference records is as follows: + +{first record} +TConfDesc record from WCTYPE.PAS +(Number of file areas - 1) div 8 + 1 of bytes of file area info + +{second record} +TConfDesc record from WCTYPE.PAS +(Number of file areas - 1) div 8 + 1 of bytes of file area info + +{... and so on} + +To compute the actual size of each Conference record in the CONFDESC.DAT file +you can use the following function: + +function ConfRecSize : Word; +var + FileRecSize : Word; + +begin + FileRecSize := (Number of file areas - 1) div 8 + 1; + ConfRecSize := SizeOf(TConfDesc) + FileRecSize; +end; + + +What do the file area bits mean? +-------------------------------- + +Each bit in the file area data at the end of each TConfDesc is used to +determine whether that conference will allow the user to access the +particular file area. For example if the 10th bit is set the the conference +makes file area 10 available to the caller if their security access +permits it. + +function GetConfFileAccess(Area : Word) : Boolean; +begin + I := Conf * 3; + GetConfFileAccess := (Word((address of file data[I div 8])^) shr (I mod 8)) and $01 = $01; +end; + diff --git a/src/wc_sdk/WCDOORS.DOC b/src/wc_sdk/WCDOORS.DOC new file mode 100755 index 0000000..afdf03d --- /dev/null +++ b/src/wc_sdk/WCDOORS.DOC @@ -0,0 +1,286 @@ + +Door Structures +--------------- +For the release of Wildcat! 4 we have redone the files that Wildcat +creates when it running an external program, the only file that remains +the same is DOOR.SYS which provides compatablility some older style +doors as well as doors used by RBBS/GAP & PCBOARD. + +DOOR.SYS is meant as a universal standard for sharing door programs, +because of this it does not contain all the information that is required +for a full blown Wildcat! 4 application. We only create the file, we do +not check it for changes when the door returns, instead we have three +other drop files that we use to handle this type of information, they +are as follows: + +SYSINFO.DAT +----------- + +This file contains all the current Wildcat! 4 system information, on +return from the door Wildcat checks this file and makes the appropriate +changes to the current running system. This is a standard text file. + +Here is the layout for SYSINFO.DAT: + +MSI HQ BBS {Line 1 - The current BBS Name } +19200 {Line 2 - Current Baud Rate (300-15200 and Local) } +8 {Line 3 - Databits } +Y {Line 4 - 'N' = No color, 'Y' = Ansi, 'R' = Rip } +Y {Line 5 - MNP connection } +52 {Line 6 - Time remaining online } +30 {Line 7 - Banked time } +14:22 02/22/94 {Line 8 - Time and date of call } +14:28 02/22/94 {Line 9 - Time and date entered door } +N {Line 10 - Started with command line option } +20 {Line 11 - Current conference number } +1 {Line 12 - Active menu number } +3 {Line 13 - Current door number } +N {Line 14 - Did the caller hang-up in door } +N {Line 15 - Reserved for future use } +Y P Z D G {Line 16 - Current commands on command stack } +SERIAL {Line 17 - Interface type (SERIAL, DIGI, FOSSIL, LOCAL } +ENGLISH {Line 18 - Current language } +14:28 02/22/94 {Line 19 - Last new files date } + +A few notes about line 15, when Wildcat creates the SYSINFO.DAT file it +takes the contents of the current command stack and writes them to line +15, all of the doors that MSI writes takes advantage of this and will +continue to process the commands, when the door is finished it will write +the remainder of the stack to line 15 where Wildcat will re-parse the line +and continue to process it. This provides a seamless interface for callers +when they are running external programs, Wildcat will accept spaces, commas +and semi-colons as delimeters. + + +FILEINFO.DAT +------------ + +This file is a list of all the currently marked files at the time the door +was started, after Wildcat has created this list it clears the current +users list in memory and upon returning from the door reads the list back +into the marked list. This allows doors the ability to add and delete files +to the current mark list, you are allowed a maximum of 99 files. +The list contains two types of files, Standard which are files found in the +current file database and Direct which are files that can be located on +any logical device. + +Here is the layout for FILEINFO.DAT: + +10 {Line 1 - The amount of marked files in this list } +2 {1 File 1 - The file area this file came from } +DRWY221.ZIP {2 File 1 - The actual file name of this file } +STANDARD {3 File 1 - The type of this file (STANDARD, DIRECT) } +N {4 File 1 - Is this file on CD ROM } +N {5 File 1 - Scanned (used by the Thumbnailer) } +10 {6 File 1 - Used by the ThumbNailer } +C:\XFS\DRWY221.ZIP {7 File 1 - Path and filenane of current file } +0 {1 File 2 - The file area this file came from } +TESTFILE.ZIP {2 File 2 - The actual file name of this file } +DIRECT {3 File 2 - The type of this file (STANDARD, DIRECT) } +N {4 File 2 - Is this file on CD ROM } +N {5 File 2 - Scanned (used by the Thumbnailer) } +0 {6 File 2 - Used by the ThumbNailer } +C:\XFS\TESTFILE.ZIP {7 File 2 - Path and filenane of current file } + +When you specify a direct file type, the only options that have any meaning +are Line 2, Line 3 and Line 7. Wildcat will use these lines to present and +send the file to the user. + + +USERREC.BIN +----------- + +This file is an actual copy of the user's records that Wildcat keeps in +memory while the user is on the BBS, this is not a text file, it is written +out as straight binary and must be loaded into a TUserRec structure in order +to be used by your program. This means you can change any of the users +information in their current record without ever touching the databases, when +Wildcat returns from a door it checks to make sure that the USERREC.BIN is +the correct size before it will load it, if it has been corrupted Wildcat +will make a note of it in the error.log and continue using the record in +memory. Make sure you know what you are doing BEFORE you start playing with +this file, you can cause a user all types of trouble if you accidently set +some of the fields incorrectly and Wildcat reads the file back in. + + +PROFILE.DAT +----------- + +This file is created at the time the user logs onto the system and anytime +you upgrade a users access, it contains the users current security profile +(TSECREC) and all of their seconday profile accesses combined into one file. +The file is used for checking access to Doors, Menu Items, Protocols, Nodes, +Conferences and File areas, the file is used by Wildcat and wcMAIL and cannot +be modified, if you change the file in any way, there is no guarantee as to +how Wildcat will react. + +Here is the format of the file: + + ++----------------------------+ +| | +| Users Current TSecRec File | +| | ++----------------------------+ +| | +| Conference access bits | +| | +| 3 For each conference | +| | ++----------------------------+ +| | +| File access bits | +| | +| 3 For each file area | +| | ++----------------------------+ + + +This layout is identical to the one used in the SECLEVEL.DAT file, except this +is one single record, for more information on how to read the bits and their +exact meaning, see the documentation on the SECLEVEL.DAT file. + + + +DOOR.SYS +-------- + + + 03/14/88 - Submitted by the "Limited Release Software Group" + +Updated: 03/21/88 +Updated: 10/22/88 KG +Updated: 07/07/90 KG, to add additional info for Raymond Clements +Updated: 07/14/91 Note to developers added by Jim Harrer/Mustang Software. + +============================================================================= + +Sample DOOR.SYS file to be used as a STANDARD for ALL Bulletin Board Systems. + +============================================================================= + + This file format has been laid out and will be presented to ALL BBS authors +in an attempt to establish a national standard for door program applications. + +BBS AUTHORS: I urge you to consider this STANDARD with respect for your 3rd + party support authors. Come on guys, make life EASY for us. + (BIG GRIN) + +============================================================================= + + I have tried to include EVERYTHING a 3rd party DOOR author would need to +provide the SYSOPS with the look and feel they want from an online program +while at the same time keeping things plain and simple to ease the problems +of interfacing programs with a system. + +This type of format is intended to be a "read-only" type of file +(although it could be written again) because most BBS's have some sort +of other file they use for re-entering the system with (PCBoard uses +PCBOARD.SYS) which is harder to read in, and changes frequently. +This file format, once established, wouldn't need to be changed EVERYTIME +a new version of the BBS software gets released and this would also +ease the demand for more info being made available in the BBS Re-Entry +file thus making life easier for both parties. If there is something +found in the following format that your BBS software may not be currently +supporting, a DEFAULT value has been suggested. + +---------- +KG, Note: + + GAP DOES treat this file as Read/Write since GAP does not use +or have any use for a Door File. GAP will re-read the DOOR.SYS upon +return from a door. But not all fields are re-read. Only those fields +that are marked with an '*' will be read by GAP when a caller returns +from a door. + + When reading this file, you should not go into an EOF loop. In +other words, you should not read until you encounter End Of File. +Instead, you should read what you KNOW is there. This allows for +additions to the end of the file without forcing all programs to be +re-compiled. + +---------- +Note from Jim Harrer: + + Beginning with WILDCAT! release 3, we will begin supporting this DOOR.SYS +Standard by creating this file in the \WC30\WCWORK\NODEx (x = Node Number) +directory. We will NOT read this file back in. If DOORS wish to change +any of the callers variables, then the door author should refer to our +USERINFO.DAT standard. + + Mustang Software will not support any future changes to DOOR.SYS. Other +BBS authors must regard this DOOR.SYS as a "Standard" and not change or +add to it in any way. DOOR authors can be assured we will not change +DOOR.SYS in the future. Any changes we need to make will be done to our +USERINFO.DAT standard. + + I hope other BBS authors will join us in agreement of not making any +additional changes to DOOR.SYS in the future. + +---------- +DOOR.SYS +-------- +COM1: <-- Comm Port - COM0: = LOCAL MODE +2400 <-- Baud Rate - 300 to 38400 +8 <-- Parity - 7 or 8 +1 <-- Node Number - 1 to 99 (Default to 1) +19200 <-- DTE Rate. Actual BPS rate to use. (kg) +Y <-- Screen Display - Y=On N=Off (Default to Y) +Y <-- Printer Toggle - Y=On N=Off (Default to Y) +Y <-- Page Bell - Y=On N=Off (Default to Y) +Y <-- Caller Alarm - Y=On N=Off (Default to Y) +Rick Greer <-- User Full Name +Lewisville, Tx. <-- Calling From +214 221-7814 <-- Home Phone +214 221-7814 <-- Work/Data Phone +PASSWORD <-- Password +110 *<-- Security Level +1456 <-- Total Times On +03/14/88 <-- Last Date Called +7560 <-- Seconds Remaining THIS call (for those that particular) +126 <-- Minutes Remaining THIS call +GR <-- Graphics Mode - GR=Graph, NG=Non-Graph, 7E=7,E Caller +23 <-- Page Length +Y <-- User Mode - Y = Expert, N = Novice +1,2,3,4,5,6,7 <-- Conferences/Forums Registered In (ABCDEFG) +7 <-- Conference Exited To DOOR From (G) +01/01/99 <-- User Expiration Date (mm/dd/yy) +1 <-- User File's Record Number +Y <-- Default Protocol - X, C, Y, G, I, N, Etc. +0 *<-- Total Uploads +0 *<-- Total Downloads +0 *<-- Daily Download "K" Total +999999 <-- Daily Download Max. "K" Limit +10/22/88 <-- Caller's Birthdate (kg) +G:\GAP\MAIN <-- Path to the MAIN directory (where User File is) (kg) +G:\GAP\GEN <-- Path to the GEN directory (kg) +Michael <-- Sysop's Name (name BBS refers to Sysop as) (kg) +Stud <-- Alias name (rc) +00:05 <-- Event time (hh:mm) (rc) +Y <-- If its an error correcting connection (Y/N) (rc) +N <-- ANSI supported & caller using NG mode (Y/N) (rc) +Y <-- Use Record Locking (Y/N) (rc) +14 <-- BBS Default Color (Standard IBM color code, ie, 1-15) (rc) +10 *<-- Time Credits In Minutes (positive/negative) (rc) +07/07/90 <-- Last New Files Scan Date (mm/dd/yy) (rc) +14:32 <-- Time of This Call (hh:mm) (rc) +07:30 <-- Time of Last Call (hh:mm) (rc) +6 <-- Maximum daily files available (rc) +3 *<-- Files d/led so far today (rc) +23456 *<-- Total "K" Bytes Uploaded (rc) +76329 *<-- Total "K" Bytes Downloaded (rc) +A File Sucker <-- User Comment (rc) +10 <-- Total Doors Opened (rc) +10283 <-- Total Messages Left (rc) + + + ***** Each line is STRAIGHT ASCII TEXT with a CR/LF at the end. ***** + + Lines marked with an '*' will be re-read in GAP when a caller + returns from a door. + + Rick Greer, the author of this Universal Specification, is no + where to be found! + + + diff --git a/src/wc_sdk/WCMSGDB.DOC b/src/wc_sdk/WCMSGDB.DOC new file mode 100755 index 0000000..dafbe50 --- /dev/null +++ b/src/wc_sdk/WCMSGDB.DOC @@ -0,0 +1,156 @@ +Wildcat 4 Message Database Notes +-------------------------------- + +The message database is no longer stored in a Filer database. There are two +files which make up a message database: + +MSGn.IX - contains the message number index +MSGn.DAT - contains the message headers and text + +The MSGn.IX file is divided into six byte records. There is one record at +the start of the file as follows: + +type + TMsgIndexHeader = record + RecordSize : Word; + ActiveRecords : Word; + NextMsgNumber : Word; + end; + +RecordSize will be set equal to 6. This is for sanity checking. +ActiveRecords is the number of active (not deleted) messages in the +conference. NextMsgNumber is the next message number that will be added +to the end of the file (this number must be updated every time you add +a message). + +The rest of the records in the file are TMsgIndexEntry records: + +type + TMsgIndexEntry = record + MsgNumber : Word; + HeaderOffset : Longint; + end; + +These records contain, for each message, the message number and byte offset +in the .DAT file of the start of the corresponding message header. + +The file is organized like this: + +ofs MSGn.IX MSGn.DAT + 0+----------------------+ +-------->+----------------------+ + | index file header | | | first message header | + | | | +----------------------+ + 1+----------------------+ | |This is the text of | + | first message number | | |the first message. It | + | offset to header data--------+ |is stored the same way| + 2+----------------------+ |it is in memory - with| + | second message number| |a single CR at the end| + | offset to header data--------+ |of each line (a CR is | + 3+----------------------+ | |required at the end of| + | | | |the last line of the | + | | | |message too). | + . . +-------->+----------------------+ + . . | second message header| + +----------------------+ + |Immediately following | + |the previous message | + |text, the next message| + |header follows. | + +----------------------+ + | | + . . + +There is a new field at the start of the message header called MagicNumber. +This field will contain one of these two constants: + +const + MagicHeaderActive = $001A1A1B; + MagicHeaderInactive = $011A1A1B; + +Active messages must have MagicHeaderActive in the MagicNumber field, and +inactive messages must have MagicHeaderInactive. An 'inactive' message is +only created when a message is edited and more text is added to the message +body. When this happens the message can no longer reside in its original +location, so its old header is marked inactive and the new message header +and text is written at the end of the MSGn.DAT file. Note that in particular, +deleted messages are NOT marked as inactive. + +When adding a new message to the database, the message header and text will +simply be appended to the MSGn.DAT file and the offset in the MSGn.IX file +will point to the offset at which the new text was added. + +Unlike Wildcat 3, there is no longer a Ctrl-Z at the end of the message text. +The end of the message is determined from the MsgBytes field in the message +header. Each line must be terminated with a CR (including the last line). +Failure to make sure this is exactly right may cause Wildcat or other programs +to not read the messages correctly. + +The unread messages are stored in a completely new way. There is a field +in the user database (see WCUSERDB.DOC) called cuFirstUnread. This is the +message NUMBER (not offset) of the first unread message in the corresponding +conference for the user. Each message has a PrevUnread and NextUnread field +that holds the message NUMBER of the previous unread message and the next +unread message, respectively, for that user. This is a doubly linked circular +list, which means that the last unread message's NextUnread points to the first +unread message, and the first unread message's PrevUnread points to the last +unread message. This is to aid in quickly adding new unread messages to the +end of the database. + +When messages are read by the recipient, the forward and back links need to +be updated to be consistent with the new state of the unread messages chain. +This process may require modifying up to three message headers plus the +cuFirstUnread field of the user record. + +When messages are deleted, they are not unhooked from the unread chain. +They just need to have their mfDeleted bit set in the message flags. +Message records are not removed from the file when they are deleted - +this is done by WcRepair or WcPack. + +Writing and modification file access to the MSGn.IX file or MSGn.DAT file is +controlled through locking the first byte of the MSGn.IX file. This is best +done with the BTIsamLockRecord and BTIsamUnlockRecord in Filer. + +Changes to Wildcat 4.01 - Conference Locking +-------------------------------------------- + +In Wildcat 4.01 we have added the ability to lock out a conference so that +programs like wcPACK can process them while the system is online. This means +that we had to a make a number of changes to both the WCMSGDB unit and the +internal code that Wildcat uses to handle message bases. + +The first change is we have created .LCK files, these are placed in a +directory called MSGLOCK that is created by Wildcat. The .LCK files are in +the format of CONFNUMBER.LCK (i.e. conference 23 would have a lock file of +23.LCK). It does not matter what the file contains, the message database code +simply checks for the files existence and if it is there the conference is +considered locked by Wildcat, wcMAIL and wcGATE and they will not touch it. + +The second change is that the message database code now identifies the +database that it is using by setting the conference number in the respective +nodeinfo record. There are two fields called ConfLock1 and ConfLock2. When a +node is not using a message database these fields are set to -1. The reason +for two fields is so that if you are moving or copying messages you can claim +both conferences so that you do not have database conflicts with programs like +wcPACK. The message database code that is supplied handles all of this for +you. + +The third change is in the way the message database code is started, instead +of just calling Init as in previous version you must first call the object +Init constructor before calling Open. If you do not do this you can cause all +kinds of problems as the object will not know what state it is in. Once you +have inited the object you call the Open function. If the database cannot be +opened because of a .LCK file, the Open function will return False. + +In cases where you are tossing mail or need to add messages to a database that +is locked we have provided a unit called WCMSGEX.PAS this is an object that +you send your messages to instead of the regular message database routines. +The object creates a file called MSGEX.DAT in the nodeinfo directory that +contains all the messages that could not be tossed due to locked conferences. +This means that tossing programs (such as wcGATE and wcMAIL) can continue to +function even though a conference is locked. The user runs a special command +line switch when wcPACK is finished packing that will read the MSGEX file and +toss all the messages into the proper message databases. + +We have provided an example program called MSGIMPRT.PAS that shows how all the +new features work and is fully compilable. + diff --git a/src/wc_sdk/WCNET.DOC b/src/wc_sdk/WCNET.DOC new file mode 100644 index 0000000..710fb67 --- /dev/null +++ b/src/wc_sdk/WCNET.DOC @@ -0,0 +1,210 @@ +Documentation for wcNET +----------------------- + +wcNET is basically a transport engine that allows two Wildcat! nodes to +transfer files between each other, the system was designed to be flexible +so that it is easy to plug into and use by third party authors, the +possibility's are unlimited! wcNET uses it's own internal protocol to handle +communications between two systems, any files that are transferred between +the systems use Zmodem batch. + +When a node is dialing out Wildat! will look up that nodes information in the +WCDIAL.DAT file and load the hostname.HUB file located in the GATEWAY/HOSTS +directory, Wildcat uses the path fields in the HUB record to determine where +the in and out directorys for this node are located, the same is true of a +node dialing in, Wildat! will look for the nodes login name in the +WCDIALIN.DAT file and then load the HUB file from there. If a HUB file cannot +be found then Wildcat! will simply return an error and terminate the session. + +When a wcNET session is started Wildcat will load the nodes record in the +WCDIAL.DAT file and then reset the modem and Dial the host node, once a +connection made Wildcat! waits for the Secured password identifier which +comes across in the form of < uniquecodestring >, where uniquecodestirng is a +randomly generated string created by Wildcat. The string is ALWAYS 34 +characters from end to end and Wildat! uses to verify the string, once it +has the Secured password identifier it sends back a custom digest string +that the other system recognizes as a wcNET hello string, the string is: + + + +Since a standard digest string is HEX and the string is using standard alpha +numeric characters there is no way a MD5 application can generate this string. +Once the string is sent the originator goes into a waiting state and looks for +a Sync command to be sent from the other system signifying that it is ready to +begin, this is necessary because some systems take quite a while to get all +the WIldcat! database files open, the originator will wait as long as the user +has the Wait For System set in the wcDIAL account before terminating the call. + +Once the orinator gets a sync it sends a request to logon which contains the +systems name and password, the remote system then processes the information +and sends either a ACK (ackknowledged) or a NAK (not acknowledged), in the +case of a NAK both systems hang up and report the failure in the activity log. +If a ACK is received from the host then if the originator has files waiting +to be sent (by processing the RQF files) it sends a request to send files, +again waiting for an ACKor NAK, if a NAK is received it skips the send part +otherwise it waits for a Sync and once received starts a Zmodem send while +the remote end starts a Zmodem receive. + +Once the transfer is completed or skipped, the Originator will check to see +if the user wants to request new information on either files or the system, +if so it sends the requests and if it gets an ACK it clears the flag in the +dial record so that the system does not request the information again. +Once this step is complete the system sends a request for new files, at this +point the remote system can either ACK or NAK, if a NAK is sent both systems +hang up and the transfer is over, if an ACK is received then the originator +waits for a SYNC from the host and once received starts a Zmodem receive. + +This is the final step and once completed the originator sends a logout +request and both sides drop carrier, an average session with no files +being sent either wayt takes about two seconds total, the protocol is +fairly simple yet very effecient. + +The Protocol +------------ + +wcNET's protocol is fairly simple, a standard request looks like this: + ++---+---+---+----+---+---+ +|CMD|NIL|LEN|DATA|NIL|CRC| ++---+---+---+----+---+---+ + +CMD is a wcNET command of 0 - 255 +NIL's are delimeters and are Char 0's +LEN is the Length of the Data being sent (up to 249) +CRC is a CRC Value of the whole string up to the last nil, the CRC is +computed and then tacked on the end of the command. Each command that is +sent has a #10 added to the end to tell the remote system that this is the +end of the command. + +Some comands contain no information, in this case the recevier simply ignores +the data being sent, it is standard practice to send a 0 in these cases. The +receiver removes the CRC and computes it's own the the remaining string and +then computes it's own, if they match then an ACK is sent, if they do not +the system sends a RESEND command at which point the originator sends the +string again, this will only happen fifteen times before wcNET will terminate +the call due to line noise or other problems. + +The protocol was designed to be simple and to carry only minimal information, +it is not designed to handle the transport of information and in fact has no +facility's for those type of functions, it is a control protocol for handling +wcNET sessions. The protocol is also designed so the originator of the call +controls the session completely, the host simply resonds to the originators +requests. Here is a list of the current protocol commands: + +const + opNONE = #0; + opSync = #1; + opAck = #2; + opNak = #3; + opResend = #4; + opLogin = #5; + opLogout = #6; + opRequestNewFiles = #7; + opRequestNewConfs = #8; + opSendNewFiles = #9; + opRequestInfo = #11; + opTransferDone = #12; + opEND = #13; + +const + Delimiter = #0; + +Remember that we only send a #10 as the terminator for a command and that is +why we do not have a #10 in the command list. OpTransferDone is sent at the +end of a file transfer to tell the remote system that the file transfer was +completed. + + +The RQF and CTL Files +--------------------- + +wcNET allows the user to send or request files using what are called +hostname.RQF files, when a wcNET run is started Wildcat! looks in the nodes +QWK out directory for any RQF files and if found processes the file line by +line verifying that each file exists and builds a hostname.CTL (or control) +file that is then used during the session, the RQF and CTL files are nothing +more that simple text files with the path/filename of the information that +if going to be sent, once the RQF is processed it is +deleted by wcNET. wcNET also handles two other types of files when it is +building a CTL file, the first is the FREQ.RQF file, which it will add to the +CTL file so that the file will be sent out to the other system, the second is +WCN files which are mail files created by wcECHO, they are also added into +the CTL file. Once the file has been created wcNET then starts the wcNET +session. + +The CTL file has two basic uses, one is a list of files to be sent, the second +is the ability to handle error recovery. When wcNET is processing RQF files +it also looks for any remaining .CTL files from previous transer sessions, if +one if found it is renamed and reprocessed into the current CTL file, wcNET +keeps a counter of the last line read in the CTL and it will start processing +the file from that point so that if a transfer is aborted wcNET will start +at the file that was aborted. Once a transfer is completely successful the +CTL file will be deleted and the internal pointer for this dialout node will +be reset. + +wcNET also handles two other types of Files, if the remote system requests +new information, wcNET looks in the GATEWAY directory for a REQINFO.CTL and +if the file exists adds it to the current CTL file, the same is true of a +conference info request (CONFINFO.CTL in the GATEWAY dir). Both of these files +are simply RQF files that wcNET processes. + +wcNET also maintains a hostname.LOG in the Rep directory, this is a list of +all the files that have been sent, this is used for +two things, wcNET uses it to prevent sending duplicate files. Since the RQF +and CTL files are simple text files, it is possible to have the same fill in +the file more that once, wcNET uses the hostname.LOG to check for this +condition so the net run does not download the same file twice. The second +use is for third party apps that need to verify that their files have been +sent. + + +FREQ Files +---------- + +If a system is setup to receive FREQ systems and an unknown system logs in, +wcNET will log the systems name and allow the system to send a FREQ.RQF file. +Once received wcNET processes the file by reading each line in the file and +adding the ContainerPath in the TDialNode structure to the begining of each +line. wcNET creates a FREQ.LOG where it notes if the file was found or not, +it also creates a hostname.CTL with the files it found and the FREQ.LOG file +added. This is all sent back to the remote system when a receieve file command +is recevied. Freq files can only be sent to originators, wcNET does not have +the ability to send FREQ files both ways. + + +Batch and WCX files +------------------- + +wcNEt uses a number of Batch files that can be taken of advantage of for +third party apps, they are as follows: + +PREMLRUN.BAT (or WCX) + +This is called before a dial out run is made, %1 is the name of either +the system being dialed or a path to the .TXT file being used to call +multiple systems. This can be used to handle the processing of files that +need to be sent, the .TXT is not open at the point this call is made so your +apps can take advantage of this and process the file before wcNET does. + +POSTMRUN.BAT (or WCX) + +This is called after a dial out run, %1 again is the name of either +the system being dialed or a path to the .TXT file being used to call +multiple systems. You can use this to process any incoming files or +mail. + +POSTMAIL.BAT (or WCX) + +This is called after a node has called in to make a wcNET run on your system, +%1 is the HubName and %2 is the QwkPath. On the Wildat! 4 Development BBS +this file is used to process incoming mail and files, we hav a WCX that +checks the QwkPath for a .WCN and if it exists it is processed with wcECHO. + + + + + + + + + diff --git a/src/wc_sdk/WCPAGEDB.DOC b/src/wc_sdk/WCPAGEDB.DOC new file mode 100644 index 0000000..9095547 --- /dev/null +++ b/src/wc_sdk/WCPAGEDB.DOC @@ -0,0 +1,25 @@ +We have revised the paging system so that users could reply to pages, system +pages or notices could be sent and sysops could globally page the users +currently on the bbs. The old paging system used a set of text files named +Page1.xtx, Page2.txt etc. THe new paging system uses two files that are very +similar to the message system, the first is the NODEPAGE.DAT file that is +used to keep the headers of each page the user receives, it also contains the +starting position and length of the text for that page stored in NODETEXT.DAT. + +The WCPAGEDB.PAS object will create both files automatically when you call +the init constructor, our suggestion is to use the routines provided as they +have been tested and are proven to work. The way you start a page is to +determine the path to the page directory, in Wildcat this is the +WCWORK\NODEXXX directory, all you need to do for the init is pass in a valid +path and the object will do the rest. You send a page the same way that you +send a message, you init the object, fillout the header and then pass in +the information to the SendPagePrim routine, the object does the rest. +Next you lock and load the nodeinfo record for that node and increment the +RequestNode field and write the nodeinfo record back out. When finished +make sure that you call the Done destructor with a setting of False as a +value of true will cause the object to erase the files. + +When Wildcat! determines that the user has pages waiting and that the user +is in a place where they can be received, it reads the pages and then when +finished deletes both files, this is one of the reasons you should use the +object as it deals with the locking scheme to prevent problems. \ No newline at end of file diff --git a/src/wc_sdk/WCSTRING.H b/src/wc_sdk/WCSTRING.H new file mode 100755 index 0000000..7ca5917 --- /dev/null +++ b/src/wc_sdk/WCSTRING.H @@ -0,0 +1,27 @@ +#define LengthByte 1 + +typedef char Str03[3+LengthByte]; +typedef char Str04[4+LengthByte]; +typedef char Str05[5+LengthByte]; +typedef char Str07[7+LengthByte]; +typedef char Str08[8+LengthByte]; +typedef char Str10[10+LengthByte]; +typedef char Str11[11+LengthByte]; +typedef char Str12[12+LengthByte]; +typedef char Str14[14+LengthByte]; +typedef char Str15[15+LengthByte]; +typedef char Str20[20+LengthByte]; +typedef char Str25[25+LengthByte]; +typedef char Str26[26+LengthByte]; +typedef char Str30[30+LengthByte]; +typedef char Str35[35+LengthByte]; +typedef char Str40[40+LengthByte]; +typedef char Str50[50+LengthByte]; +typedef char Str60[60+LengthByte]; +typedef char Str64[64+LengthByte]; +typedef char Str67[67+LengthByte]; /* DirStr */ +typedef char Str70[70+LengthByte]; +typedef char Str73[73+LengthByte]; +typedef char Str75[75+LengthByte]; +typedef char Str79[79+LengthByte]; /* PathStr */ +typedef char Str80[80+LengthByte]; diff --git a/src/wc_sdk/WCTYPE.C b/src/wc_sdk/WCTYPE.C new file mode 100755 index 0000000..2cc4a8a --- /dev/null +++ b/src/wc_sdk/WCTYPE.C @@ -0,0 +1,212 @@ +#include "wctype.h" + +const WORD MaximumConfs = 32760; +const WORD MaximumFiles = 32760; +const WORD MaximumMsgs = 65520; +const int MaximumProfiles = 1000; +const int MaximumDoors = 1000; +const int MaximumIdle = 1000; +const int MaximumLang = 1000; +const int MaximumGroups = 1000; + +const int mpFixedRate = 0x01; +const int mpCtsRtsFlow = 0x02; +const int mpDropOnExit = 0x04; + +const long BaudNumber[] = {0, 300, 1200, 2400, 4800, 7200, + 9600, 12000, 14400, 16800, 19200, 21600, + 24000, 26400, 28800, 38400, 57600, 115200}; + +const long mwLogOffIfNotVerified = 0x00000001; +const long mwSysopDropToDos = 0x00000002; +const long mwShowSec = 0x00000004; +const long mwUseClearScreens = 0x00000008; +const long mwFreeFormPhone = 0x00000010; +const long mwEncryptPasswords = 0x00000020; +const long mwOverwriteChatFiles = 0x00000040; +const long mwLockOutForSecError = 0x00000080; +const long mwReserved4 = 0x00000100; +const long mwDynamicFileKeys = 0x00000200; +const long mwSysopReadPrivate = 0x00000400; +const long mwShowUserSec = 0x00000800; +const long mwPrinterOnline = 0x00001000; +const long mwBulletsOptional = 0x00002000; +const long mwTerminateOnDoors = 0x00004000; +const long mwAutoId = 0x00008000; +const long mwForce8N1 = 0x00010000; +const long mwReserved3 = 0x00020000; +const long mwCopyOnCD = 0x00040000; +const long mwIndexLongDesc = 0x00080000; +const long mwAllowLocalUpgrades = 0x00100000; +const long mwPreferredChatMode = 0x00200000; +const long mwLanguageAtLogon = 0x00400000; + +const int mwTCBulletins = 0x0001; +const int mwTCNews = 0x0002; +const int mwTCFiles = 0x0004; +const int mwTCDetailDL = 0x0008; +const int mwTCCheckDups = 0x0010; +const int mwTCFaxSupport = 0x0020; +const int mwTCNetSendPrivate = 0x0040; + +const int mwCTUserAliasAllowed = 0x0001; +const int mwCTActionWords = 0x0002; +const int mwCTPaging = 0x0004; +const int mwCTPrivateChan = 0x0008; +const int mwCTChangeTopic = 0x0010; + +const long pfAscii = 0x00000001; +const long pfXmodem = 0x00000002; +const long pfXmodemCrc = 0x00000004; +const long pfXmodem1K = 0x00000008; +const long pfXmodem1kG = 0x00000010; +const long pfYmodem = 0x00000020; +const long pfYModemG = 0x00000040; +const long pfKermit = 0x00000080; +const long pfZmodem = 0x00000100; +const long pfExternal1 = 0x00000200; +const long pfExternal2 = 0x00000400; +const long pfExternal3 = 0x00000800; +const long pfExternal4 = 0x00001000; +const long pfExternal5 = 0x00002000; +const long pfExternal6 = 0x00004000; +const long pfExternal7 = 0x00008000; +const long pfExternal8 = 0x00010000; +const long pfExternal9 = 0x00020000; +const long pfExternal10 = 0x00040000; +const long sfFastLogin = 0x00080000; +const long sfOverwrite = 0x00100000; +const long sfShowPWFiles = 0x00200000; +const long sfTCFileAccess = 0x00400000; +const long sfUpOverTime = 0x00800000; +const long sfDnOverTime = 0x01000000; +const long sfReserved = 0x02000000; +const long sfDistMail = 0x04000000; +const long sfModifyUpload = 0x08000000; +const long sfNoAuthWrite = 0x10000000; + +const int cfChatSysop = 0x0001; +const int cfActionWords = 0x0002; +const int cfUninvite = 0x0004; +const int cfPageUsers = 0x0008; +const int cfModerator = 0x0010; +const int cfChatAlias = 0x0020; + +const int sConfRead = 0x01; +const int sConfWrite = 0x02; +const int sConfJoin = 0x04; + +const int sFileList = 0x01; +const int sFileDown = 0x02; +const int sFileUp = 0x04; + + +const int cfPromptToKillMsg = 0x0001; +const int cfHighAscii = 0x0002; +const int cfAllowCarbon = 0x0004; +const int cfReserved1 = 0x0008; +const int cfREserved2 = 0x0010; +const int cfReturnReceipt = 0x0020; +const int cfLongAddress = 0x0040; +const int cfUseAlias = 0x0080; +const int cfAllowAttach = 0x0100; +const int cfPromptToKillAttach = 0x0200; +const int cfShowCtrlLines = 0x0400; + + +const int diMultiUser = 0x01; +const int diInUse = 0x02; +const int diMenuHook = 0x04; // !!.N; +const int diSmallSys = 0x08; +const int diAliasName = 0x10; + +const long niLptr = 0x00000001; +const long niPage = 0x00000002; +const long niBell = 0x00000004; +const long niKybd = 0x00000008; +const long niLocalNext = 0x00000010; +const long niScreenWrite = 0x00000020; +const long niEventNext = 0x00000040; +const long niBringDown = 0x00000080; +const long niKillCaller = 0x00000100; +const long niPagingSysop = 0x00000200; +const long niOnLocally = 0x00000400; +const long niMNPConnect = 0x00000800; +const long niSysopNext = 0x00001000; +const long niUseVgaMode = 0x00002000; +const long niCapture = 0x00004000; +const long niStayDown = 0x00008000; + +const long ufNeverDelete = 0x00000001; +const long ufChatPage = 0x00000002; +const long ufHotKey = 0x00000004; +const long ufLockedOut = 0x00000008; +const long ufQuoteOnReply = 0x00000010; +const long ufBellAtLogin = 0x00000020; +const long ufNoPrivMail = 0x00000040; +const long ufNoDelMail = 0x00000080; +const long ufTCNoPvtExport = 0x00000100; +const long ufTCSendFromYou = 0x00000200; +const long ufTCSendNewFiles = 0x00000400; +const long ufTCSendNewBulls = 0x00000800; +const long ufTCUploadHangup = 0x00001000; +const long ufReserved = 0x00002000; +const long ufScanPrivate = 0x00004000; +const long ufTCScanFaxes = 0x00008000; +const long ufTCScripts = 0x00010000; +const long ufSortedLists = 0x00020000; +const long ufCrashMail = 0x00040000; +const long ufFileAttach = 0x00080000; +const long ufCaptureUser = 0x00100000; +const long ufSevenBitAscii = 0x00200000; +const long ufTCSmallCtrlDat = 0x00400000; + +const int cufSysopMail = 0x01; +const int cufSelected = 0x02; +const int cufLockedOut = 0x04; +const int cufTitleOff = 0x08; +const int cufPersonalOnly = 0x10; +const int cufScanAll = 0x20; +const int cufAllAttachs = 0x40; + +const int mfPrivate = 0x0001; +const int mfReceiveable = 0x0002; +const int mfReceived = 0x0004; +const int mfReceipt = 0x0008; +const int mfCarboned = 0x0010; +const int mfForwarded = 0x0020; +const int mfEchoFlag = 0x0040; +const int mfHasReplies = 0x0100; +const int mfDeleted = 0x0200; +const int mfTagged = 0x0400; +const int mfSent = 0x0800; +const int mfChgAttach = 0x1000; + +extern int grGroupOnline = 0x0001; +extern int grRequest = 0x0002; +extern int grSendMsg = 0x0004; +extern int grGroupHidden = 0x0008; +extern int grFixedDevice = 0x0010; + +extern int cqReceived = 0x0001; +extern int cqDeleted = 0x0002; + +const int fiNeverOverwrite = 0x0001; +const int fiNeverDelete = 0x0002; +const int fiDontCharge = 0x0004; +const int fiUploadInProgress = 0x0008; +const int fiOnCD = 0x0010; +const int fiOffLine = 0x0020; +const int fiFailedScan = 0x0040; +const int fiFreeTime = 0x0080; + +const int mufChangeConf = 0x01; +const int mufTopLevel = 0x02; + +const int etSun = 0x01; +const int etMon = 0x02; +const int etTue = 0x04; +const int etWed = 0x08; +const int etThu = 0x10; +const int etFri = 0x20; +const int etSat = 0x40; diff --git a/src/wc_sdk/WCTYPE.H b/src/wc_sdk/WCTYPE.H new file mode 100755 index 0000000..a7fa3ed --- /dev/null +++ b/src/wc_sdk/WCTYPE.H @@ -0,0 +1,1018 @@ +/************************************************ + + Global record structures for WILDCAT! version 4.10 + Copyright 1986,94 Mustang Software Inc. + All rights reserved. + + Last Revised: 03-02-95 + Revision: 'U' + Responsibility: Eric Cozzi + +************************************************/ + +#include "wcstring.h" + +typedef unsigned char BYTEBOOL; +typedef unsigned int WORD; +typedef unsigned char BYTE; + +/* Defined maximum limits */ + +extern const WORD MaximumConfs; +extern const WORD MaximumFiles; +extern const WORD MaximumMsgs; +extern const int MaximumProfiles; +extern const int MaximumDoors; +extern const int MaximumIdle; +extern const int MaximumLang; +extern const int MaximumGroups; /* !!.410 */ + +typedef WORD Date; +typedef long Time; + +typedef struct tagTDateTime { + Date D; + Time T; +} TDateTime; + +/* Various bit set types */ + +typedef BYTE TNodeInfoBits[32]; +typedef TNodeInfoBits *PNodeInfoBits; +typedef BYTE TArray1000Bits[126]; +typedef BYTE TArray32768Bits[4096]; + + +/* Modem profile file (*.MDM) */ + +extern const int mpFixedRate; +extern const int mpCtsRtsFlow; +extern const int mpDropOnExit; + +enum TGetBaud {gbResult1, gbResult2, gbByCR, gbDTE}; +enum TAnswer {aRing, aResult, aAutoAnswer}; +enum TInterface {iSerial, iDigiboard, iFossil, iOS2, iNone}; /* !!.410 */ + +enum TBaudType {bNone, b300, b1200, b2400, b4800, b7200, + b9600, b12000, b14400, b16800, b19200, b21600, + b24000, b26400, b28800, b38400, b57600, b115200}; + +#define TBaudCount 18 /* Must be updated to reflect actual TBaudType count! */ + +const extern long BaudNumber[]; + +typedef struct tagTModemProfile { + WORD Version; + Str30 ModemName; + long InitBaud; + BYTE Commport, + CommIrq, + CarrierDelay, + pFlags, + FifoTrigger; + WORD CommBase, + RingDelay, + DropDtrDelay, + PreLogDelay, + ResultDelay, + ResetDelay; + BYTE AnswerPhone; /* enum TAnswer */ + BYTE DetermineBaud; /* enum TGetBaud */ + BYTE InterfaceType; /* enum TInterface */ + Str60 RingStr, + AnswerStr, + CallerIdStr, + ModemReset, + OnHook, + OffHook, + ErrorStr, + ModemInit; + Str20 BaudStrings[20]; + long BaudRates[20]; + Str10 DumpStr, + ResetStr, + WriteStr; + Str40 SetupStr[3]; + Str64 Notes[3]; + BYTE FifoSend; + BYTE Reserved[49]; +} TModemProfile; + +/* MakeWild file (MAKEWILD.DAT) */ + +extern const long mwLogOffIfNotVerified; +extern const long mwSysopDropToDos; +extern const long mwShowSec; +extern const long mwUseClearScreens; +extern const long mwFreeFormPhone; +extern const long mwEncryptPasswords; +extern const long mwOverwriteChatFiles; +extern const long mwLockOutForSecError; +extern const long mwReserved4; /* !!.401 */ +extern const long mwDynamicFileKeys; +extern const long mwSysopReadPrivate; +extern const long mwShowUserSec; +extern const long mwPrinterOnline; +extern const long mwBulletsOptional; +extern const long mwTerminateOnDoors; +extern const long mwAutoId; +extern const long mwForce8N1; +extern const long mwReserved3; +extern const long mwCopyOnCD; +extern const long mwIndexLongDesc; +extern const long mwAllowLocalUpgrades; +extern const long mwPreferredChatMode; +extern const long mwLanguageAtLogon; + +extern const int mwTCBulletins; +extern const int mwTCNews; +extern const int mwTCFiles; +extern const int mwTCDetailDL; +extern const int mwTCCheckDups; +extern const int mwTCFaxSupport; +extern const int mwTCNetSendPrivate; /* !!.410 */ + +extern const int mwCTUserAliasAllowed; +extern const int mwCTActionWords; +extern const int mwCTPaging; +extern const int mwCTPrivateChan; +extern const int mwCTChangeTopic; + +enum TModerate {mdAll, mdPrivate, mdPublic, mdNone}; +enum TSwapMethod {tDisk, tEms, tXms, tNoSwap}; +enum TMonitorType {sColor, sMono, sAuto}; +enum TSystemAccess {cOpen, cClosed, cClosedComment, + cClosedQuestionnaire}; +enum TDBProtect {dbNone, dbMarkMode, dbSaveMode}; +enum TScreenBlank {sbNone, sbBox, sbBlackOut}; +enum TConsoleSec {csNone, csPassword, csNoConsole}; +enum TSettingSec {ssYes, ssMessage, ssNo}; +enum TNetSupportType {wcNoNet, wcNovell, wcMsNet}; +enum TSavePacketLevel {plNone, plNetStatus, plAll}; +enum TColorMenus {tAscii, tAnsi, tRip}; +enum TOverlayType {otDisk, otEms, otXms}; +enum TDupUserType {duNone, duNoneChk, duAllow}; +enum TRipMode {trNone, trRip, trRipForced}; /* !!.401 */ + +typedef BYTE TDriveTable[26]; + +typedef struct tagTCBaudLimitRec +{ + WORD MaxPacket; + WORD MaxConf; +} TCBaudLimitRec; + +typedef struct tagTPackerRec +{ + char Letter; + Str30 Description; + Str03 Extension; + Str08 PackerExe; + Str40 PackerCmdLine; + Str08 UnpackerExe; + Str40 UnpackerCmdLine; +} TPackerRec; + +typedef struct tagTExcludeBullRec +{ + WORD Conference; + WORD BullNumber; +} TExcludeBullRec; + +typedef struct tagTMakeWildRec +{ + Str04 MWVersion; + BYTE Revision; /* !!.410 */ + Str25 SysopName; + Str05 Reserved1; + Str25 FirstCall; + Str08 PacketId; + Str25 Phone; + Str30 BBSName; + Str67 FileDataBasePath, + UserDataBasePath, + NodeInfoPath, + ReservedPath, + BatchFilePath, + ModemFilePath, + ChatFilePath, + LanguagePath; + Str10 NewUserSec; + BYTE MonitorType; /* enum TMonitorType */ + BYTE CloseOption; /* enum TSystemAccess */ + BYTE Network; /* enum TNetSupportType */ + BYTE DatabaseMode; /* enum TDBProtect */ + BYTE ScreenBlankMode; /* enum TScreenBlank */ + WORD ScrollBackBuffer; + char ExtLtr[10]; + Str12 ExtUpBatch[10], + ExtDnBatch[10], + ExtName[10]; + BYTEBOOL ExtBatchDriven[10]; + BYTE ExtraMemForOverlay, + NodeId, + SecTries; + WORD MaxFileAreas, + MaxConfAreas, + FirstCallLimit; + long MwFlags; + Str40 DateFormat, + TimeFormat; + Str07 RegString; + WORD FlexEventInactivity; + Time FlexEventForceTime; + TDriveTable LockDriveTable; + Str04 DefaultExt; + Str12 ThumbNailFile; + Str14 ConsolePassword; + BYTE ConsoleSec; /* enum TConsoleSec */ + BYTE ChangePhone, /* enum TSettingSec */ + ChangeAlias, + ChangeBDate; + BYTE SwapMethod; /* enum TSwapMethod */ + TPackerRec Packer[10]; + Str30 TCCity; + WORD TCFlags; + WORD PreScanArea; + BYTE SavePacketLevel; /* enum TSavePacketLevel */ + TCBaudLimitRec TCMaxPerBaud[TBaudCount]; + TExcludeBullRec TCExcludeBulls[40]; + WORD MaxChannelSize; + WORD ChatTimeOut; + WORD TalkTimeOut; + BYTE ChatWaitTime; + BYTE ChatModerate; /* enum TModerate */ + long ChatFlags; + TModemProfile ModemProfile; + BYTE HoldOverlay; /* enum TOverlayType */ + BYTE DupUserLevel; /* enum TDupUserType */ + BYTE RipMode; /* !!.401 enum TRipMode */ + Str26 GroupTable; /* !!.410 */ + Str30 DefaultGroupName; /* !!.410 */ + char Reserved[139]; +} TMakeWildRec; + +typedef TMakeWildRec *PMakeWildRec; + +/* Security profiles (SECLEVEL,DAT) */ + +enum TSysopAccess {saNo, saYes, saMaster, saNetStatus}; +enum TRatioAction {raNothing, raWarn, raNoDownloads}; +enum TProfileType {ptFullProfile, ptSecondary}; +enum TUploadType {utNoDupes, utWarnOfDupe, utIgnore}; + +typedef BYTE TMenuItemAccess[8]; + +extern const long pfAscii; +extern const long pfXmodem; +extern const long pfXmodemCrc; +extern const long pfXmodem1K; +extern const long pfXmodem1kG; +extern const long pfYmodem; +extern const long pfYModemG; +extern const long pfKermit; +extern const long pfZmodem; +extern const long pfExternal1; +extern const long pfExternal2; +extern const long pfExternal3; +extern const long pfExternal4; +extern const long pfExternal5; +extern const long pfExternal6; +extern const long pfExternal7; +extern const long pfExternal8; +extern const long pfExternal9; +extern const long pfExternal10; + +extern const long sfFastLogin; +extern const long sfOverwrite; +extern const long sfShowPWFiles; +extern const long sfTCFileAccess; +extern const long sfUpOverTime; +extern const long sfDnOverTime; +extern const long sfReserved; +extern const long sfDistMail; +extern const long sfModifyUpload; +extern const long sfNoAuthWrite; /* !!.410 */ + +extern const int cfChatSysop; +extern const int cfActionWords; +extern const int cfUninvite; +extern const int cfPageUsers; +extern const int cfModerator; +extern const int cfChatAlias; + +extern const int sConfRead; +extern const int sConfWrite; +extern const int sConfJoin; + +extern const int sFileList; +extern const int sFileDown; +extern const int sFileUp; + +typedef struct tagTSecHeader +{ + Str10 ProfileName; + BYTE ProfileType; /* enum TProfileType */ +} TSecHeader; + +typedef struct tagTSecRec +{ + Str10 ProfileName; + BYTE ProfileType; /* enum TProfileType */ + Str10 ExpiredName; + Str08 DisplayName; + TNodeInfoBits NodeAccess; + TArray1000Bits DoorAccess; + TMenuItemAccess MenuItemAccess; + BYTE SysopStatus; /* enum TSysopAccess */ + BYTE RatioAction; /* enum TRatioAction */ + BYTE UploadComp, + MaxRatio; + char Menus; + WORD ChatFlags; + long sFlags; + Date ExpireDate; + WORD DailyTimeLimit, + MaxLogon, + VerifyBDate, + VerifyPhone, + MaxDL, + MaxDK, + MaxKRatio, + MaxConfAreas, + MaxFileAreas, + FaxFlags; + Str10 DoorProfile; + BYTE UploadAccess; /* enum TUploadType */ + char Reserved[36]; +} TSecRec; + +/* Conference name list (CONFDESC.IX, CONFDESC.UX) */ + +typedef struct tagTConfList +{ + Str25 ConfName; + WORD ConfNum; +} TConfList; + +/* Conference list (CONFDESC.DAT) */ + +extern const int cfPromptToKillMsg; +extern const int cfHighAscii; +extern const int cfAllowCarbon; +extern const int cfReserved1; +extern const int cfReserved2; +extern const int cfReturnReceipt; +extern const int cfLongAddress; +extern const int cfUseAlias; +extern const int cfAllowAttach; +extern const int cfPromptToKillAttach; +extern const int cfShowCtrlLines; + +enum TMailType {mtNormalPublicPrivate, + mtNormalPublic, + mtNormalPrivate, + mtFidoNetMail, + mtInternetEmail, + mtInternetNewsgroup}; +enum TValidName {vnYes, vnNo, vnPrompt}; + +typedef struct tagTConfDesc +{ + Str25 ConfName, + ConfOp; + Str12 ConfShortName; + BYTE ConfMail; /* enum TMailType */ + TArray1000Bits DoorAccess; + Str67 BullPath, + QuesPath, + MenuPath, + HelpPath, + DisplayPath, + MsgPath, + AttachPath; + BYTE Reserved1; + WORD cFlags, + ConfNumber; + BYTE ValidNames; /* enum TValidName */ + WORD MaxMessages, + MaxFileAreas; + char Reserved[50]; +} TConfDesc; + +/* File area name file (FILEAREA.IX, FILEAREA.UX) */ + +typedef struct tagTFileList +{ + Str30 AreaName; + WORD AreaNumber; +} TFileList; + +/* File Area file (FILEAREA.DAT) */ + +typedef struct tagTFileAreaRec +{ + Str30 AreaName; + Str67 AreaPath; + Str08 FileDatabase; /* !!.410 */ + char Reserved[11]; +} TFileAreaRec; + +/* Language file (LANGDESC.DAT) */ + +typedef struct tagTLangDesc +{ + Str08 Language; + Str73 Description; + char YesChar; + char NoChar; +} TLangDesc; + +/* Door file (DOOR.DAT) */ + +extern const int diMultiUser; +extern const int diInUse; +extern const int diMenuHook; +extern const int diSmallSys; +extern const int diAliasName; /* !!.410 */ + +typedef struct tagTDoor +{ + Str20 diName; + Str08 diBat; + Str08 diDisp; + BYTE diFlags; + char Reserved[20]; +} TDoor; + +/* Idle program data (IDLEPGM.DAT) */ + +typedef struct tagTIdleProgram +{ + Str30 Name; + Str79 ShellPath; + Str14 Password; + char Reserved[20]; +} TIdleProgram; + +/* Master info file (NODEINFO.DAT record 0) */ + +typedef struct tagTMasterInfo +{ + Str05 VersionId; + TNodeInfoBits ActiveNodes; + long TotalCalls, + TotalUsers, + TotalFiles, + TotalMessages; + WORD TempCalls, + TempMsgs, + TempDownloads, + TempUploads; + BYTE ReservedWords[8]; + TDateTime TempReset; + long HighestUserId; + BYTE ChatCount; + char Reserved[160]; +} TMasterInfo; + +/* Nodeinfo file (NODEINFO.DAT) */ + +extern const long niLptr; +extern const long niPage; +extern const long niBell; +extern const long niKybd; +extern const long niLocalNext; +extern const long niScreenWrite; +extern const long niEventNext; +extern const long niBringDown; +extern const long niKillCaller; +extern const long niPagingSysop; +extern const long niOnLocally; +extern const long niMNPConnect; +extern const long niSysopNext; +extern const long niUseVgaMode; +extern const long niCapture; +extern const long niStayDown; + +enum TNodeStatus {nsDown, nsUp, nsSigningOn, nsLoggedIn, + nsEventProcessing, nsRepair, nsReceiveFax}; +enum TUserStatus {usNone, usFileTransfer, usEnteringMsg, + usInDoor, usInDOS, usPChat, usDChat}; +enum TSysWindow {swNoWindow, swSingleWindow, swOrigWindow, + swBigWindow}; + +typedef struct tagTNodeInfo +{ + Str10 Security; + BYTE NodeStatus; /* enum TNodeStatus */ + BYTE UserStatus; /* enum TUserStatus */ + BYTE SysWindow; /* enum TSysWindow */ + Str25 CallersName; + Str30 From; + Str50 PrevCaller; + long UserID; + long BaudRate; + TDateTime TimeCalled, + PrevLogOff, + TimeOff; + int RequestNode; + long CallerNumber, + nFlags, + QuoteIndex, + LowestBaud; + Str20 CurStatus; + long NumberOfCalls; + long LockConf1; /* !!.401 */ + long LockConf2; /* !!.401 */ + char Reserved[42]; +} TNodeInfo; + +/* User database (ALLUSERS.DAT) */ + +extern const long ufNeverDelete; +extern const long ufChatPage; +extern const long ufHotKey; +extern const long ufLockedOut; +extern const long ufQuoteOnReply; +extern const long ufBellAtLogin; +extern const long ufNoPrivMail; +extern const long ufNoDelMail; +extern const long ufTCNoPvtExport; +extern const long ufTCSendFromYou; +extern const long ufTCSendNewFiles; +extern const long ufTCSendNewBulls; +extern const long ufTCUploadHangup; +extern const long ufReserved; /* !!.410 */ +extern const long ufTCScanPrivate; +extern const long ufTCScanFaxes; +extern const long ufTCScripts; +extern const long ufSortedLists; +extern const long ufCrashMail; +extern const long ufFileAttach; +extern const long ufCaptureUser; +extern const long ufSevenBitAscii; +extern const long ufTCSmallCtrlDat; /* !!.401 */ + +extern const int cufSysopMail; +extern const int cufSelected; +extern const int cufLockedOut; +extern const int cufTitleOff; +extern const int cufPersonalOnly; +extern const int cufScanAll; +extern const int cufAllAttachs; /* !!.410 */ + +enum TPacketType {pText, pQwk}; +enum TUserConfRecType {ucrIndex, ucrData}; + +typedef struct tagTUserConfData +{ + BYTE cuFlags; + WORD cuLastRead; + WORD cuFirstUnread; +} TUserConfData; + +typedef TUserConfData TUserConfArray[1024]; + +typedef struct tagTUserConfPageHeader +{ + WORD RecLen; + BYTE RecType; /* enum TUserConfRecType */ + long UserID; + int Page; + long This; +} TUserConfPageHeader; + +typedef struct tagTUserConfPage +{ + WORD RecLen; + BYTE RecType; /* enum TUserConfRecType */ + long UserID; + int Page; + long This; + TUserConfArray UserConfData; +} TUserConfPage; + +typedef struct tagTUserConfIndex +{ + WORD RecLen; + BYTE RecType; /* enum TUserConfRecType */ + long OffSets[32]; +} TUserConfIndex; + +enum TEditor {ePrompt, eNormal, eFullScreen}; +enum TMorePrompt {mpErasePrompt, mpNextLine}; +enum TFileDisplay {fdSingleLine, fdDoubleLine, fdFull, fdLister}; /* !!.410 */ +enum TExpertiseLevel {elNovice, elRegular, elExpert}; +enum TSex {sUnKnown, sMale, sFemale}; +enum TMsgDisplay {mdScroll, mdClear, mdHeader}; +enum TScrnDisplay {sdNoColor, sdColor, sdRip, sdAuto}; +enum TProtocol {pAll, pXmodem, pXmodemCRC, pYmodem, pYModemG, + pXModem1K, pXmodem1KG, pKermit, pZmodem, pAscii, + pExt1, pExt2, pExt3, pExt4, pExt5, pExt6, pExt7, + pExy8, pExt9, pExt10}; + +typedef Str10 TSecondarys[5]; + +typedef struct tagTUserRec +{ + long Status; + Str25 UserName; + Str30 From; + Str14 Password; + long UserID; + Str15 PhoneNumber, + DataNumber, + FaxNumber, + ComputerType; + Str10 SecLevel; + TSecondarys Secondary; + Str30 Company, + Address1, + Address2, + City; + Str15 State; + Str10 Zip; + Str25 Country; + Str10 Title; + Str25 Alias; + Str08 NovellName; + Str08 Language; + Str30 Comment[5]; + BYTE Sex; /* enum TSex */ + BYTE Editor; /* enum TEditor */ + BYTE MorePrompt; /* enum TMorePrompt */ + BYTE Xpert; /* enum TExpertiseLevel */ + BYTE TransferMethod; /* enum TProtocol */ + BYTE ScreenDisplay; /* enum TScrnDisplay */ + BYTE FileDisplay; /* enum TFileDisplay */ + BYTE MsgDisplay; /* enum TMsgDisplay */ + BYTE LinesPerPage; + TDateTime LastCall, + LastNewFiles; + WORD ExpireDate, + MemoDate, + UserSince, + BirthDate; + WORD ActiveConf, + MsgsWritten, + Uploads, + Downloads, + TimesOn, + TimeLeft; + long UFlags, + DailyDL, + DailyDK, + TotalUK, + TotalDK, + MinutesLogged, + SubScriptionBalance, + NetMailBalance; + BYTE ReservedByte; + BYTE TCPacket; /* enum TPacketType */ + char TCPacker; + WORD TCMaxPerConf; + WORD TCMaxPerPacket; + WORD TCMaxAttachSize; + long UserConfData; + WORD DefaultGroup; /* !!.410 */ + BYTE Reserved[48]; +} TUserRec; + +/* Message Files (MSGxxx.IX) */ + +extern const int mfPrivate; +extern const int mfReceiveable; +extern const int mfReceived; +extern const int mfReceipt; +extern const int mfCarboned; +extern const int mfForwarded; +extern const int mfEchoFlag; +extern const int mfHasReplies; +extern const int mfDeleted; +extern const int mfTagged; +extern const int mfSent; +extern const int mfChgAttach; /* !!.410 */ + +typedef struct tagTFidoAddress +{ + WORD Zone, + Net, + Node, + Point; +} TFidoAddress; + +typedef char TMsgText[65520]; + +typedef struct tagTMsgHeader +{ + long MagicNumber; + WORD MsgNumber; + Str70 Orig; + Str10 OrigTitle; + long OrigUserID; + Str70 Dest; + Str10 DestTitle; + long DestUserID; + Str70 Subject; + Str08 Network; + TDateTime MsgTime, + ReadTime; + WORD mFlags; + WORD Reference; + TFidoAddress FidoFrom, + FidoTo; + WORD MsgBytes; + Str12 InternalAttach; + Str12 ExternalAttach; + WORD PrevUnread; + WORD NextUnread; + WORD FidoFlags; + long Cost; + BYTE Reserved[20]; +} TMsgHeader; + +typedef struct tagTMsgIndexHeader /* Must be same size as TMsgIndexEntry */ +{ + WORD RecordSize; + WORD ActiveRecords; + WORD NextMsgNumber; +} TMsgIndexHeader; + +typedef struct tagTMsgIndexEntry /* Must be same size as TMsgIndexHeader */ +{ + WORD MsgNumber; + long HeaderOffset; +} TMsgIndexEntry; + +/* Groups database (GROUPS.DAT) */ /* !!.410 */ + +extern const int grGroupOnline; +extern const int grRequest; +extern const int grSendMsg; +extern const int grGroupHidden; +extern const int grFixedDevice; + +typedef struct tagTGroupHeader +{ + Str30 GroupName; + Str08 FileDatabase; + Str11 VolumeId; + Str79 VolumeFile; + Str79 Location; + WORD gFlags; + WORD MaxFileAreas; + WORD LockedCount; + WORD FirstArea; + WORD LastArea; + BYTE Reserved[46]; +} TGroupHeader; + +/* Group Index (GROUPS.IX/UX) */ /* !!.410 */ + +typedef struct tagTGroupList +{ + Str30 GroupName; + WORD GroupNumber; +} TGroupList; + +/* Request Database (REQUESTS.DAT) */ /* !!.410 */ + +extern const int cqReceived; +extern const int cqDeleted; + +typedef struct tagTCDRequest +{ + WORD Area; + Str08 Database; + Str79 Location; + Str12 FileName; + LONG UserId; + TDateTime ReqDate; + TDateTime SentDate; + WORD reqFlags; +} TCDRequest; + +/* CD Rom Areas Database (DATBASE.ARE) */ /* !!.410 */ + +typedef struct tagTGroupDesc +{ + Str30 AreaName; + Str79 AreaPath; + WORD AreaNum; + WORD NewArea; + BYTE Reserved[18]; +} TGroupDesc; + +/* File Database (ALLFILES.DAT) */ + +extern const int fiNeverOverwrite; +extern const int fiNeverDelete; +extern const int fiDontCharge; +extern const int fiUploadInProgress; +extern const int fiOnCD; +extern const int fiOffLine; +extern const int fiFailedScan; +extern const int fiFreeTime; + +typedef BYTE TFileMsgText[1201]; +typedef Str10 TKeyArray[6]; + +typedef struct tagTFileRec +{ + long Status, + Size; + Str12 FileName; + Str14 Password; + TDateTime FileTime, + LastAccessed; + Str25 Uploader; + long UploaderID; + Str75 Desc; + WORD MsgBytes, + fFlags, + NumOfAccess, + Cost, + Area; + TKeyArray Keywords; + Str79 StoredPath; + TFileMsgText MsgText; +} TFileRec; + +typedef struct tagTFileHeader +{ + long Status, + Size; + Str12 FileName; + Str14 Password; + TDateTime FileTime, + LastAccessed; + Str25 Uploader; + long UploaderID; + Str75 Desc; + WORD MsgBytes, + fFlags, + NumOfAccess, + Cost, + Area; + TKeyArray Keywords; + Str79 StoredPath; +} TFileHeader; + +/* Menu files (xxx.MNU) */ + +enum TMenuCommand {cmBulletins, /***** Main menu *****/ + cmDoorMenu, + cmSysopComment, + cmPageSysop, + cmShowHellos, + cmQuestionnaires, + cmLocateUser, + cmChangeSettings, + cmStatistics, + cmUsersList, + cmNewsLetter, + cmWhoIsOnline, + + cmReadMessage, /***** Message menu *****/ + cmScanMessages, + cmEnterMessage, + cmDeleteMessage, + cmCheckMailAtMenu, + cmUpdateConfScans, + cmMailDoor, + + cmFullFileInfo, /***** File menu *****/ + cmListFilesByArea, + cmDownloadFiles, + cmUploadFiles, + cmListFilesByDate, + cmSearchFiles, + cmFileStats, + cmPersonalStats, + cmViewArcFile, + cmReadAFile, + cmEditMarkList, + + cmManageEvents, /***** Sysop menu *****/ + cmEditUserRec, + cmReadActLog, + cmEraseActLog, + cmEditFileRec, + cmSysopStatus, + cmEditNodes, + cmSysopDownload, + cmSysopUpload, + + cmChangeConference, /***** Global options *****/ + cmRunQuesFile, + cmXpertLevel, + cmDumpHelpFile, + cmDisplayMenuFile, + cmDisplayDispFile, + cmDisplayTxtFile, + cmDisplayBulletin, + cmLogoffUser, + cmRunScript, + cmGotoMenu, + cmMenuHook, + cmStackCommands, + cmPageUser, + cmwcCHAT, + cmSelectGroups, /* !!.410 */ + cmReturnPressed, + cmInvalidCommand}; + +#define MaxMenuItems 40 + +extern const int mufChangeConf; +extern const int mufTopLevel; + +typedef struct tagTMenuItem +{ + char Selection; + Str30 CommandDesc; + BYTE CommandID; /* enum TMenuCommand */ + BYTEBOOL CommandParam; + Str40 CommandStr; + WORD CommandNum; +} TMenuItem; + +typedef struct tagTMenuRec +{ + TArray1000Bits SecAccess; + BYTE MenuFields; + Str35 MenuDesc; + Str08 MenuFile; + WORD ConfNumber; + BYTE muFlags; + TMenuItem MenuItem[MaxMenuItems]; +} TMenuRec; + +/* Event file (EVENTxxx.DAT) */ + +extern const int etSun; +extern const int etMon; +extern const int etTue; +extern const int etWed; +extern const int etThu; +extern const int etFri; +extern const int etSat; + +enum TEventMethod {emFlex, emSoft, emHard}; +enum TEventShell {esShell, esTerminate}; +enum TEventSchedule {esHourly, esDaily, esMonthly, esYearly}; +enum TEventAction {eaNoPage, eaResetStats, eaRunBatch, eaAllPageOff, + eaNodePage, eaDosNext, eaAllPageOn, eaBaudLimit, + eaRunScript, eaBellOn, eaBellOff, eaAllBellOn, + eaAllBellOff}; + +typedef struct tagTEvent +{ + BYTE Method; /* enum TEventMethod */ + BYTE Action; /* enum TEventAction */ + long BaudRate; + BYTEBOOL Active; + TDateTime NextExec, + LastExec; + BYTE DayBitSet; + BYTE ShellType; /* enum TEventShell */ + Str79 BatchPath; + BYTE Schedule; /* enum TEventSchedule */ + BYTE HourDelay, + DayOfMonth, + Month; +} TEvent; + +/* Chat file data (CHANNELS.DAT) */ + +enum TChannelStatus {csNotInUse, csPublic, csPrivate, csModerated, + csPriMod}; + +typedef struct tagTChannelRecord +{ + Str08 FName; + Str08 DispFile; + Str25 Name; + Str25 ModName; + Str08 ActionFile; + Str30 Topic; + BYTE ChanStatus; /* enum TChannelStatus */ + WORD Moderator; + WORD Users; + WORD MaxUsers; + BYTEBOOL LogChannel; + BYTEBOOL Profanity; + TArray1000Bits SecAccess; +} TChannelRecord; + +/* Action word files (*.ACT) */ + +typedef struct tagTActionRecord +{ + Str10 KeyWord; + Str80 ToOriginator; + Str80 ToTarget; + Str80 ThirdPerson; + Str80 NoTarget; +} TActionRecord; diff --git a/src/wc_sdk/WCUSERDB.DOC b/src/wc_sdk/WCUSERDB.DOC new file mode 100755 index 0000000..83bf3d2 --- /dev/null +++ b/src/wc_sdk/WCUSERDB.DOC @@ -0,0 +1,116 @@ +Wildcat 4 User Database Notes +----------------------------- + +The user records are stored in a fixed length Filer database. There +are no variable length parts to a user record any more, so no matter +how many conferences you have, a user record is the same size. + +The variable length parts of the user record are stored in another file +in the same directory called USERCONF.DAT. This file has a small header: + +type + TUserConfFileHeader = record + totalconfs : Word; { total number of conferences } + end; + +The header is at offset zero at the start of the file. The remainder +of the file contains either index pages or a data pages. The index +page has the following structure: + +type + TUserConfIndex = record + RecLen : Word; { length of this record in bytes } + RecType : TUserConfRecType; { ucrIndex record type id } + offsets : array [0..31] of Longint; + end; + +Not all of the 32 offsets are actually used - the number that are used +is defined by the following function: + + function MaxPages(MaxConfAreas : Word) : Word; + const + MaxChunk = 1024; + begin + MaxPages := (LongInt(MaxConfAreas) + MaxChunk - 1) div MaxChunk; + end; + +A data page has the following structure: + +type + TUserConfData = record + cuFlags : Byte; { user's flags as defined in wctype.pas } + cuLastRead : Word; { last read message number } + cuFirstUnread : Word; { first unread message number } + end; + + TUserConfPage = record + RecLen : Word; { length of this record in bytes } + RecType : TUserConfRecType; { ucrData record type id } + UserID : LongInt; { user id number used by wcrepair } + Page : Integer; { page number of this page } + This : Longint; { offset of this page in bytes } + UserConfData : array [0..1023] of TUserConfData; + end; + +The ConfUser array in TConfUserPage will not always be 1024 records long. +The size of this structure is variable length depending on the number of +conferences defined in Makewild and is computed according to the following +function: + + function PageRecords(MaxConfAreas : Word) : Word; + const + MaxChunk = 1024; + var + Chunks : Word; + begin + Chunks := (LongInt(MaxConfAreas) + MaxChunk - 1) div MaxChunk; + PageRecords := ((LongInt(MaxConfAreas) + Chunks - 1) div Chunks); + end; + +This function balances the space used by each record so the amount of wasted +space is minimal. So for 1024 conferences there will be one 1024 record +page, but for 1025 conferences the pages will be split into two 513 record +chunks, so there is only one wasted record. + +There is a field called UserConfData in the fixed part of the user +record which points to the offset of the index page for that user in +USERCONF.DAT. Wildcat always creates an index page for each new user +added to the database, so you can assume this page exists. However, +not all of the data pages will exist so you have to take this into +account and perhaps create pages as necessary (if a page does not exist +its offset will be 0 in the index page). + +New pages are always created at the end of the file and old pages (from +a deleted user, for example) are not reused. WcRepair will pack the +USERCONF.DAT file and remove all unnecessary pages. + +This is a diagram of how this setup might all fit together with 1025 +conferences (with 1024 or fewer conferences there is only one user data +page so things are kind of degenerate): + + ALLUSERS.DAT ofs USERCONF.DAT + +-------------------+ 0+----------------------------+ + | | | (header) | + . . | | + . . 2+----------------------------+ + | | | | + +-------------------+ . . + | JOE USER | . . + | (user info) | | | + | UserConfData=50 ------>50+----------------------------+ + +-------------------+ | 61 | (index page + | | | 2661 | for JOE USER) + . . 61+----------------------------+ + | JOE USER, page=0, this=61 | (page 0 for JOE) + | (513 TConfUser records) | + 2661+----------------------------+ + | JOE USER, page=1, this=2661| (page 1 for JOE) + | (513 TConfUser records) | + 5261+----------------------------+ + | | + . . + +All writing or modification access to the USERCONF.DAT file should be done +only while the ALLUSERS.DAT file is locked in Filer (using BTLockFileBlock). +This is done to prevent having to lock a regular DOS file (which is a pain +and is also different on various networks - Filer takes care of this). diff --git a/src/wc_sdk/basesupp.pas b/src/wc_sdk/basesupp.pas new file mode 100644 index 0000000..3ddf4ac --- /dev/null +++ b/src/wc_sdk/basesupp.pas @@ -0,0 +1,416 @@ +{********************************************************************} +{* BASESUPP.PAS - Basic interrupt and DOS support routines *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit BaseSupp; + +interface + +uses +{$IFDEF FPC} + Dos; +{$ELSE} +{$IFDEF Windows} + WinProcs {!!.41} + {$IFNDEF VER80} {!!.51} + , WinDos {!!.51} + {$ENDIF}; {!!.51} +{$ELSE} + {$IFNDEF FPC} + {$IFDEF DPMI} + WinAPI, {!!.41} + {$ENDIF} + {$ENDIF} + Dos; +{$ENDIF} +{$ENDIF} + +{$IFDEF FPC} +type +{$IFDEF GO32V2} + GenRegisters = Registers; +{$ELSE} + GenRegisters = record + case Integer of + 0: (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: Word); + 1: (AL, AH, BL, BH, CL, CH, DL, DH: Byte); + end; +{$ENDIF} +{$ELSE} +type + GenRegisters = record + case Integer of + 0: (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: Word); + 1: (AL, AH, BL, BH, CL, CH, DL, DH: Byte); + end; +{$ENDIF} + +var + AdrMsDos, + AdrIntr, + AdrDPMIRealModeIntr, + AdrDosVersion, + AdrSetIntVec, + AdrGetIntVec, + AdrGetTime, + AdrGetDate : Pointer; + +{$IFDEF FPC} +procedure CallMsDos(var Regs : GenRegisters); +procedure CallIntr(IntNo : Byte; var Regs : GenRegisters); +procedure CallDPMIRealModeIntr(IntNo : Byte; var Regs : GenRegisters); +function CallDosVersion : Word; +procedure CallSetIntVec(IntNo : Byte; Vector : Pointer); +procedure CallGetIntVec(IntNo : Byte; var Vector : Pointer); +procedure CallGetTime(var Hour, Minute, Second, Sec100 : Word); +procedure CallGetDate(var Year, Month, Day, DayOfWeek : Word); +{$ELSE} +procedure CallMsDos(var Regs : GenRegisters); inline + ($FF / $1E / AdrMsDos); {call far dword ptr [AdrMsDos]} + {-Call MsDos via AdrMsDos and allows to use type GenRegisters} + + +procedure CallIntr(IntNo : Byte; var Regs : GenRegisters); inline + ($FF / $1E / AdrIntr); {call far dword ptr [AdrIntr]} + {-Call Intr via AdrMsDos and allows to use type GenRegisters} + + +procedure CallDPMIRealModeIntr(IntNo : Byte; + var Regs : GenRegisters); inline + ($FF / $1E / AdrDPMIRealModeIntr); + {-call far dword ptr [AdrDPMIRealModeIntr]} + {-Call Intr via AdrDPMIRealModeIntr and allows to use type GenRegisters} + + +function CallDosVersion : Word; inline + ($FF / $1E / AdrDosVersion); {call far dword ptr [AdrDosVersion]} + {-Call DosVersion via AdrDosVersion} + + +procedure CallSetIntVec(IntNo : Byte; Vector : Pointer); inline + ($FF / $1E / AdrSetIntVec); {call far dword ptr [AdrSetIntVec]} + {-Call SetIntVec via AdrSetIntVec} + + +procedure CallGetIntVec(IntNo : Byte; var Vector : Pointer); inline + ($FF / $1E / AdrGetIntVec); {call far dword ptr [AdrGetIntVec]} + {-Call GetIntVec via AdrGetIntVec} + + +procedure CallGetTime(var Hour, Minute, Second, Sec100 : Word); inline + ($FF / $1E / AdrGetTime); {call far dword ptr [AdrGetTime]} + {-Call GetTime via AdrGetTime} + + +procedure CallGetDate(var Year, Month, Day, DayOfWeek : Word); inline + ($FF / $1E / AdrGetDate); {call far dword ptr [AdrGetDate]} + {-Call GetDate via AdrGetDate} +{$ENDIF} + + +procedure DefaultRegisters(var Regs : GenRegisters); + +{DefaultZeroedRegisters deleted} {!!.41} + +function CallAllocRealModeMem(Size : Word; {!!.41} + var RealModePtr, + ProtModePtr : Pointer) : Boolean; + +procedure CallFreeRealModeMem(Size : Word; {!!.41} + ProtModePtr : Pointer); + + +implementation + +{$IFDEF FPC} +{$IFDEF GO32V2} +uses + go32; +{$ENDIF} +{$ELSE} +{$IFDEF VER80} {!!.51} +uses DosSupp; {!!.51} +{$ENDIF} {!!.51} +{$ENDIF} + +procedure DefaultRegisters(var Regs : GenRegisters); +begin + FillChar(Regs, SizeOf(Regs), 0); + {$IFNDEF FPC} + Regs.DS := DSeg; + Regs.ES := DSeg; + {$ENDIF} +end; + +{$IFDEF FPC} +{$IFDEF GO32V2} +procedure CallMsDos(var Regs : GenRegisters); +begin + MsDos(Regs); +end; + +procedure CallIntr(IntNo : Byte; var Regs : GenRegisters); +begin + Intr(IntNo, Regs); +end; + +procedure CallDPMIRealModeIntr(IntNo : Byte; var Regs : GenRegisters); +var + RealRegs : TRealRegs; +begin + FillChar(RealRegs, SizeOf(RealRegs), 0); + RealRegs.AX := Regs.AX; + RealRegs.BX := Regs.BX; + RealRegs.CX := Regs.CX; + RealRegs.DX := Regs.DX; + RealRegs.BP := Regs.BP; + RealRegs.SI := Regs.SI; + RealRegs.DI := Regs.DI; + RealRegs.DS := Regs.DS; + RealRegs.ES := Regs.ES; + RealRegs.Flags := Regs.Flags; + RealIntr(IntNo, RealRegs); + Regs.AX := RealRegs.AX; + Regs.BX := RealRegs.BX; + Regs.CX := RealRegs.CX; + Regs.DX := RealRegs.DX; + Regs.BP := RealRegs.BP; + Regs.SI := RealRegs.SI; + Regs.DI := RealRegs.DI; + Regs.DS := RealRegs.DS; + Regs.ES := RealRegs.ES; + Regs.Flags := RealRegs.Flags; +end; + +procedure CallSetIntVec(IntNo : Byte; Vector : Pointer); +begin + Dos.SetIntVec(IntNo, Vector); +end; + +procedure CallGetIntVec(IntNo : Byte; var Vector : Pointer); +begin + Dos.GetIntVec(IntNo, Vector); +end; +{$ELSE} +{ Non-DOS platforms: stub implementations for DOS interrupt calls } +procedure CallMsDos(var Regs : GenRegisters); +begin + { No-op on non-DOS platforms } + Regs.Flags := Regs.Flags or 1; { set carry flag to indicate error } +end; + +procedure CallIntr(IntNo : Byte; var Regs : GenRegisters); +begin + Regs.Flags := Regs.Flags or 1; +end; + +procedure CallDPMIRealModeIntr(IntNo : Byte; var Regs : GenRegisters); +begin + Regs.Flags := Regs.Flags or 1; +end; + +procedure CallSetIntVec(IntNo : Byte; Vector : Pointer); +begin +end; + +procedure CallGetIntVec(IntNo : Byte; var Vector : Pointer); +begin + Vector := nil; +end; +{$ENDIF GO32V2} + +function CallDosVersion : Word; +begin + CallDosVersion := Dos.DosVersion; +end; + +procedure CallGetTime(var Hour, Minute, Second, Sec100 : Word); +begin + Dos.GetTime(Hour, Minute, Second, Sec100); +end; + +procedure CallGetDate(var Year, Month, Day, DayOfWeek : Word); +begin + Dos.GetDate(Year, Month, Day, DayOfWeek); +end; +{$ENDIF FPC} + +{$IFNDEF FPC} +{$IFDEF DPMIOrWnd} {!!.41} +procedure DPMIRealModeIntr(IntNr : Byte; var Regs : GenRegisters); far; +var + DPMIRegs : record + DI : LongInt; + SI : LongInt; + BP : LongInt; + Reserved : LongInt; + BX : LongInt; + DX : LongInt; + CX : LongInt; + AX : LongInt; + Flags : Word; + ES : Word; + DS : Word; + FS : Word; + GS : Word; + IP : Word; + CS : Word; + SP : Word; + SS : Word; + end; + DPMIError : Word; +begin + DPMIError := 0; + FillChar(DPMIRegs, SizeOf(DPMIRegs), 0); + with DPMIRegs do begin + AX := Regs.AX; + BX := Regs.BX; + CX := Regs.CX; + DX := Regs.DX; + BP := Regs.BP; + SI := Regs.SI; + DI := Regs.DI; + DS := Regs.DS; + ES := Regs.ES; + Flags := Regs.Flags; + end; + asm + MOV AX, 0300H + MOV BL, IntNr + MOV BH, 0 + MOV CX, 0 + PUSH SS + POP ES + LEA DI, [BP+OFFSET DPMIRegs] + INT 31H + JNC @@EndPoint + MOV DPMIError, AX + @@EndPoint: + end; + with DPMIRegs do begin + Regs.AX := AX; + Regs.BX := BX; + Regs.CX := CX; + Regs.DX := DX; + Regs.BP := BP; + Regs.SI := SI; + Regs.DI := DI; + Regs.DS := DS; + Regs.ES := ES; + Regs.Flags := Flags; + end; +end; +{$ENDIF} + + +{$ENDIF FPC ifndef} + +function CallAllocRealModeMem(Size : Word; {!!.41} + var RealModePtr, + ProtModePtr : Pointer) : Boolean; +var + L : LongInt; +begin + CallAllocRealModeMem := False; + {$IFDEF FPC} + GetMem(RealModePtr, Size); + if RealModePtr = nil then Exit; + ProtModePtr := RealModePtr; + {$ELSE} + {$IFDEF DPMIOrWnd} + L := GlobalDosAlloc(Size); + if L <> 0 then begin {!!.51} + RealModePtr := Ptr(L Shr 16, 0); + ProtModePtr := Ptr(L and $FFFF, 0); + end + else begin + Exit; + end; + {$ELSE} + if MaxAvail < Size then Exit; + GetMem(RealModePtr, Size); + ProtModePtr := RealModePtr; + {$ENDIF} + {$ENDIF} + CallAllocRealModeMem := True; +end; + + +procedure CallFreeRealModeMem(Size : Word; {!!.41} + ProtModePtr : Pointer); +begin + {$IFDEF FPC} + FreeMem(ProtModePtr, Size); + {$ELSE} + {$IFDEF DPMIOrWnd} + if GlobalDosFree(LongInt(ProtModePtr) Shr 16) = 0 then + {do nothing}; + {$ELSE} + FreeMem(ProtModePtr, Size); + {$ENDIF} + {$ENDIF} +end; + + +begin + {$IFDEF FPC} + AdrMsDos := @CallMsDos; + AdrIntr := @CallIntr; + AdrDPMIRealModeIntr := @CallDPMIRealModeIntr; + AdrDosVersion := @CallDosVersion; + AdrSetIntVec := @CallSetIntVec; + AdrGetIntVec := @CallGetIntVec; + AdrGetTime := @CallGetTime; + AdrGetDate := @CallGetDate; + {$ELSE} + AdrMsDos := @MsDos; + AdrIntr := @Intr; + {$IFDEF DPMIOrWnd} {!!.41} + AdrDPMIRealModeIntr := @DPMIRealModeIntr; + {$ELSE} + AdrDPMIRealModeIntr := @Intr; + {$ENDIF} + AdrDosVersion := @DosVersion; + AdrSetIntVec := @SetIntVec; + AdrGetIntVec := @GetIntVec; + AdrGetTime := @GetTime; + AdrGetDate := @GetDate; + {$ENDIF} +end. diff --git a/src/wc_sdk/billglo.pas b/src/wc_sdk/billglo.pas new file mode 100644 index 0000000..a2db406 --- /dev/null +++ b/src/wc_sdk/billglo.pas @@ -0,0 +1,402 @@ +unit BillGlo; + +(************************************************************************** + +Global record structure for wcBILLING version 4.12 +Copyright 1995 Mustang Software Inc. All rights reserved. + +Last Revised 11/22/95 + +Revision 'B' + +Resonsibility: SLR + +**************************************************************************) + +{$I wcdefine.inc} + +{$O+} + +interface + +uses + Dos, + wctype +{$IFDEF OPRO} + ,OpDate; +{$ELSE} + {$IFDEF TPro} + ,TpDate; + {$ELSE} + ; + +type + Date = Word; + Time = LongInt; + DateTimeRec = record + D : Date; + T : Time; + end; + {$ENDIF} +{$ENDIF} + +const + MaxHolidays = 100; {Constant dictating the number of holidays} + MaxNodes = 250; {Max possible number of nodes on BBS} + BillingPath = 'BILLING\'; {Location of billing files from within Wildcat!} + +type + TProfileType = (ptPostPay, {You accrue a balance and then you pay} + ptPrePay); {You start off with a balance and you run out} + +type + TExceptionTimeDays = record + Start, {Start time} + Ending : Time; {End time} + BillingProfile : String[8]; {Profile to use} + end; + +type + THolidays = record + DateMask : String[8]; {11/25/**} + BillingProfile : String[8]; {Profile to use} + end; + +type + THolidaysArray = array[1..MaxHolidays] of THolidays; + +type + tCostHandling = (fcWildcatOnly, {Charge only to Wildcat balance} + fcWildcatBilling,{Charge to both Wildcat and Billing} + fcBillingOnly); {Charge to billing only.} +{$IFDEF OPRO} +const + TProfileString : array[TProfileType] of String[10] = ('Post Pay','Pre Pay'); + +const + CostString : array[tCostHandling] of string[34] = ('Wildcat! account balance only', + 'Wildcat! & billing credits balance', + 'Billing credits balance only'); +{$ENDIF} + +const + bfHonorExpiredProfile = $0001; {When account balance is out, used expired Security profile} + bfReserved1 = $0002; {Reserved for future use} + bfReserved2 = $0004; {Reserved for future use} + bfReserved3 = $0008; {Reserved for future use} + bfReserved4 = $0010; {Reserved for future use} + +type + {Filename: .CFG} + PBillProfile = ^TBillProfile; + TBillProfile = record + Version : String[4]; {Version number} + ProfileName : String[8]; {Name of Profile} + ProfileType : TProfileType; {Type of billing} + ConferenceProfile : String[8]; {Conference profile} + FileProfile : String[8]; {File Areas profile} + DoorProfile : String[8]; {Doors profile} + RegularRates : Integer; {Regular Increment rates} + ChatRates : Integer; {rate while in chat} + FAXRates : Integer; {rate while in wcFAX} + wcMAILRates : Integer; {rate while in wcMAIL} + ExceptionRates : array[DayType] of TExceptionTimeDays; {Exception rates} + HolidayRates : THolidaysArray; {Holiday increment rates} + Threshholds : array[1..2] of LongInt; {Display file when threshold reached} + PostPayCap : LongInt; {Credit Limit for postpay} + CreditValue : Integer; {Value of Credit to 1 unit of currency} + EnterChat : Integer; {Cost to enter wcCHAT} + EnterFAX : Integer; {Cost to enter wcFAX} + EnterMail : Integer; {Cost to enter wcMAIL} + bFlags : Word; {Flags} + FAXCostHandling : tCostHandling; {FAX costs applied to what?} + CodeProfile : String[8]; {wcCODE program profile} {!!.412} + end; + +type + {Filename: .CNF Each record corresponds to each conference in file} + TConfProfile = object + ConferenceName : String[25]; {Conference Name} + MsgWrittenRates : Integer; {Messages written rate} + MsgKByteWriteRates : Integer; {Message KByte rate} + UploadAttachment : Integer; {Attachment rate} + UploadAttachKByte : Integer; {KByte for attachments} + MsgReadRates : Integer; {Messages read rate} + MsgKByteReadRates : Integer; {Message KByte Rate} + DownloadAttachment : Integer; {Attachment rate} + DownloadAttachKByte : Integer; {Download attach KByte rate} + MaxConferences : Word; {Sanity field} + Filler : array[1..44] of Byte; {Filler} + end; + +type + {FileName: .FAR Each record corresponds to each file area} + TFileProfile = object + FileAreaName : String[30]; {File area name} + FileDownloadRate : Integer; {Download rate} + DownloadKByteRate : Integer; {Download KByte rate} + DownloadMByteRate : Integer; {Download MByte rate} + FileUploadRate : Integer; {Upload rate} + UploadKByteRate : Integer; {Upload KByte rate} + UploadMByteRate : Integer; {Upload MByte rate} + MaxFileAreas : Word; {Sanity field} + FileCostHandling : tCostHandling; {File Cost Handling} + FileView : Integer; {Viewing file cost} {!!.412} + Filler : array[1..41] of Byte; {Filler} + end; + +type + {FileName: .DOR Each record corresponds to each door in door.dat} + TDoorProfile = object + DoorName : String[20]; {Door Name} + DoorPMRate : Integer; {Per minute rate in door} + CosttoEnter : Integer; {Cost to enter this door} + TotalDoors : Word; {Total Number of Doors in profile} + Filler : array[1..42] of Byte; {Filler} + end; + +type + {FileName: .WCD Each record corresponds to a wcCODE applications} + TCodeProfile = object {!!.412} + ProgramName : String[8]; {WCCODE Program Name} + ProgramPMRate : Integer; {Per minute rate in wcCODE program} + CostToEnter : Integer; {Cost to enter this wcCODE program} + Filler : array[1..256] of Byte; {Filler space reserved for future use} + end; + +const + TotalTransactionTypes = 25; {0..25. 26 actual transaction types} + +type + TTransactionType = (ttFileDownload, + ttFileUpload, + ttLogin, + ttLogOff, + ttEnterDoor, + ttReturnFromDoor, + ttMessageWritten, + ttMessageRead, + ttBalanceExpired, + ttDownloadAttach, + ttUploadAttach, + ttPayment, + ttMiscellaneous, + ttFileView, {!!.412} + ttEnterCodeProgram, {!!.412} + ttReturnFromCodeProgram, {!!.412} +(*************************************************************************** +* * +* The following transaction types are not used anywhere in wcBilling and * +* can be used by any 3rd party programs. Remember that if you add a * +* transaction of one of these types, you need to make sure and fill in the * +* Comment field as to what created the transaction as well as what the * +* transaction is for. * +* * +***************************************************************************) + tt3rd1, {Reserved for 3rd Party Apps} {!!.412} + tt3rd2, {Reserved for 3rd Party Apps} {!!.412} + tt3rd3, {Reserved for 3rd Party Apps} {!!.412} + tt3rd4, {Reserved for 3rd Party Apps} {!!.412} + tt3rd5, {Reserved for 3rd Party Apps} {!!.412} + tt3rd6, {Reserved for 3rd Party Apps} {!!.412} + tt3rd7, {Reserved for 3rd Party Apps} {!!.412} + tt3rd8, {Reserved for 3rd Party Apps} {!!.412} + tt3rd9, {Reserved for 3rd Party Apps} {!!.412} + tt3rd10); {Reserved for 3rd Party Apps} {!!.412} + +{$IFDEF OPRO} +const + TTransactionString : array[TTransactionType] of String[19] = ('File download', + 'File upload', + 'Log on', + 'Log off', + 'Entered door', + 'Exited door', + 'Message written', + 'Message read', + 'Balance expired', + 'Download attachment', + 'Upload attachment', + 'Payment', + 'Miscellaneous', + 'File Viewing', + 'Entered Program', + 'Exited Program', + '3rd Party 1', + '3rd Party 2', + '3rd Party 3', + '3rd Party 4', + '3rd Party 5', + '3rd Party 6', + '3rd Party 7', + '3rd Party 8', + '3rd Party 9', + '3rd Party 10'); +{$ENDIF} + +type + {FileName: BILLING.DAT\BILLING.IX\BILLING.DIA} + PTransactionRec = ^TTransactionRec; + TTransactionRec = record + Status : LongInt; {} + Number : LongInt; {Transaction Number} + Processed : Boolean; {Have we invoiced this one already} + Profile : String[8]; + UserName : String[25]; {Name of User making transaction} + UserId : LongInt; {User this belongs too} + DT : DateTimeRec; {Date & Time of transaction} + NodeId : Word; {CurrentNode} + TransactionCost : Integer; {Cost of transaction} + TransactionType : TTransactionType; {Type of transaction} + Comment1 : String[70]; {Comments} + ProcessedDate : DateTimeRec; {Date & Time we processed this transaction} + Filler : array[1..100] of byte; + end; + +{$IFDEF OPRO} +type + {Yes/No/Both Type for filter} + YesNoBoth = (Yes, No, Both); + +type + ConditionType = (GreaterEqual, LessEqual); + +const + condString : array[ConditionType] of String[24] = ('Greater than or equal to', + 'Less than or equal to'); + +const + ynbString : array[YesNoBoth] of String[4] = ('Yes', 'No', 'Both'); + +type + {Billing Transaction Match .BTM} + PTransactionMatchRec = ^TTransactionMatchRec; + TTransactionMatchRec = record + Version : String[5]; + NodeIdLo, + NodeIdHi : Word; + NumberLo, + NumberHi, + UserIdLo, + UserIdHi : LongInt; + UserName : String[25]; + TransactionAge : Word; + taCondition : ConditionType; + TransactionCostLo, + TransactionCostHi : Integer; + TransactionType : set of TTransactionType; + Comment1 : String[70]; + Processed : YesNoBoth; + DTDateLo, + DTDateHi, + ProcessedDateLo, + ProcessedDateHi : Date; + Profile : String[8]; + end; + +type + tReport = (tDBF, tcomma, tfixed, tinvoice); + +const + ReportString : array[tReport] of String[15] = ('DBF', + 'Comma Delimited', + 'Fixed Length', + 'Invoice'); + +type + tHandling = (tMarkAsProcessed, + tDontChangeTRec, + tDeleteTransaction); + +const + HandlingString : array[tHandling] of String[18] = ('Mark As Processed', + 'Don''t Change', + 'Delete Transaction'); +type + tOutAction = (oAppend, + oOverwrite); + +type + tOutputFormat = (ofFile, + ofEmail); + +const + OutputActionString : array[tOutAction] of String[9] = ('Append', + 'Overwrite'); + +const + OutputFormatString : array[tOutputFormat] of String[15] = ('File or Printer', + 'EMail Message'); + +type + {*.BEX or *.RPT} + PReportRecord = ^TReportRecord; + TReportRecord = record + Version : String[5]; + Report : tReport; + TemplateFileName : DirStr; + OutputFileName : DirStr; + OutputAction : TOutAction; + Handling : tHandling; + OutputFormat : tOutputFormat; + OutputConference : Word; + OutputSubject : String[70]; + OutputFrom : String[70]; + OutputFromId : LongInt; + OverallTemplate : DirStr; + OverallFormat : tOutputFormat; + OverallConference : Word; + OverallSubject : String[70]; + OverallTo : String[70]; + OverallToId : LongInt; + OverallFileName : DirStr; + OverallAction : TOutAction; + end; + +type + tSymbolLocation = (slLeft, + slRight); + +const + SymbolLocationString: array[tSymbolLocation] of String[5] = ('Left', + 'Right'); + +type + {BILLING\BILLING.SUP} + PBillingSetup = ^TBillingSetup; + TBillingSetup = record + Version : String[5]; + NumberFormat : String[14]; + CurrencyFormat : String[14]; + CurrencySymbol : String[10]; + SymbolLocation : tSymbolLocation; + end; + +type + tLogHandling = (lAppendToBackup, + lRenameToBackup, + lEraseLogs); + +const + LogHandlingString : array[tLogHandling] of String[28] = ('Append to *.BAK', + 'Overwrite & Rename to *.BAK', + 'Erase during process'); + +type + {BILLING\.BIM} + TImportRec = record + Status : LongInt; {} + Cost : Integer; {Cost of transaction} + tType : TTransactionType; {Type of transaction} + Comment1 : String[70]; {Comments} + ImportName : DirStr; + end; +{$ENDIF} + +implementation + +end. + + + + diff --git a/src/wc_sdk/bldbrows.pas b/src/wc_sdk/bldbrows.pas new file mode 100644 index 0000000..8d1e999 --- /dev/null +++ b/src/wc_sdk/bldbrows.pas @@ -0,0 +1,68 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +program BldBrows; + {-Simple program to build all B-Tree Filer browsers via Make} + +{$I btdefine.inc} + +{$IFDEF Win32} +uses + Filer, + VRec, + FvcBrows; +{$ELSE} + +{$IFNDEF Windows} +{$IFDEF Only_OPro} { <-- This define is set by FILER.MAK } +{$DEFINE HasOpro} +{$ENDIF} +{$IFDEF Both_TPro_OPro} { <-- This define is set by FILER.MAK } +{$DEFINE HasOpro} +{$ENDIF} +{$ENDIF} + +uses + Filer, + Vrec, + {$IFDEF Windows} + {$IFDEF Ver80} + FvcBrows; + {$ELSE} + WBrowser; + {$ENDIF} + {$ELSE} + {$IFDEF WantTV} { <-- This define is set by FILER.MAK } + TVBrows, + {$ENDIF} + {$IFDEF HasOPro} + OPBrow, + {$ENDIF} + Browser; + {$ENDIF} +{$ENDIF} + +begin +end. \ No newline at end of file diff --git a/src/wc_sdk/bldfiler.pas b/src/wc_sdk/bldfiler.pas new file mode 100644 index 0000000..091269b --- /dev/null +++ b/src/wc_sdk/bldfiler.pas @@ -0,0 +1,71 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +program BldFiler; {!!.51} + {-Simple program to build all B-Tree Filer units via Make} + +{$I btdefine.inc} + +uses +{$IFDEF Win32} + Filer, + Vrec, + BufRecIO, + NumKey32, + Rebuild, + Reorg, + ReIndex, + VRebuild, + VReorg, + FixToVar, + Restruct; +{$ELSE} +{$IFDEF UseFilerDLL} + RexCHook, +{$ELSE} + {$IFDEF MSDOS} + EMSHeap, + EMSSupp, + {$ENDIF} +{$ENDIF} + BaseSupp, +{$IFDEF VER80} + DosSupp, +{$ENDIF} + Filer, + Vrec, + BufRecIO, + NumKeys, + Rebuild, + Reorg, + ReIndex, + VRebuild, + VReorg, + FixToVar, + Restruct; +{$ENDIF} + +begin +end. diff --git a/src/wc_sdk/bldnettl.pas b/src/wc_sdk/bldnettl.pas new file mode 100644 index 0000000..d25fbcb --- /dev/null +++ b/src/wc_sdk/bldnettl.pas @@ -0,0 +1,42 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +program BldNetTl; + {-Simple program to build all B-Tree Filer network tool units via Make} + +{$I btdefine.inc} + +uses + {$IFDEF DPMIOrWnd} + DPMI, + {$ENDIF} + NetBIOS, + NWBase, NWConn, NWFile, NWBind, NWSema, NWMsg, NWTTS, NWPrint, + NWIPXSPX, + OOPSema, + Share; + +begin +end. diff --git a/src/wc_sdk/bldtools.pas b/src/wc_sdk/bldtools.pas new file mode 100644 index 0000000..3680bca --- /dev/null +++ b/src/wc_sdk/bldtools.pas @@ -0,0 +1,51 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +program BldTools; + {-Simple program to build all B-Tree Filer tool units via Make} + +{$I btdefine.inc} + +uses + Filer, + Vrec, + {$IFNDEF Win32} + {$IFDEF MSDOS} + MSort, + TPAlloc, + {$ENDIF} + CArrConv, + DBImpExp, + {$IFDEF Ver70} + MSortP, + {$ENDIF} + {$IFDEF Ver80} + MSortP, + {$ENDIF} + {$ENDIF} + IsamTool; + +begin +end. diff --git a/src/wc_sdk/brdefopt.inc b/src/wc_sdk/brdefopt.inc new file mode 100644 index 0000000..3b8ecbb --- /dev/null +++ b/src/wc_sdk/brdefopt.inc @@ -0,0 +1,59 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Definition of to use B-Tree Shell or B-Tree Isam for Browser} + (********************************************************************) + (******************) {$DEFINE BRUseIsam} (**********************) + (******************) { $DEFINE BRUseShell} (**********************) + (********************************************************************) + {-Either BRUseShell or BRUseIsam may be defined, not both. At least one + of them must be defined to determine whether B-Tree Filer or B-Tree + Shell is used for the browser} + + +(**********************************************************************) +(**********************************************************************) +{Don't change anything beyond this point} + +{--Test the BRUseXXX defines} + {$IFDEF BRUseShell} + {$IFDEF BRUseIsam} + ** ERROR ** You can only define one of BRUseShell or BRUseIsam + {$ENDIF} + {$ELSE} + {$IFNDEF BRUseIsam} + ** ERROR ** One of BRUseShell or BRUseIsam *must* be defined + {$ENDIF} + {$ENDIF} + +{--Conditional defines that affect this unit} + {$IFDEF BRUseShell} + {$I shdefine.inc} + {$ENDIF} + {$IFDEF BRUseIsam} + {$I btdefine.inc} + {$ENDIF} diff --git a/src/wc_sdk/brlisam.inc b/src/wc_sdk/brlisam.inc new file mode 100644 index 0000000..5784fb8 --- /dev/null +++ b/src/wc_sdk/brlisam.inc @@ -0,0 +1,328 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +Const + RetriesOnLock = 32; + {-Number of retries of a read operation on lock error} + DelayTime = 30; + {-Delay between retries of operation on lock error} + + Function BRLBrowser.BrowserCallAllowed : Boolean; + + Begin + BrowserCallAllowed := True; + End; + + + Function BRLBrowser.BRGetRec ( Var RR : RowRec; + AskUser, + ReadFull : Boolean ) : Integer; + + Var + Len : Word; + RT : Word; + LResult : Integer; {!!.51} + + Begin + RT := 0; + Repeat + If VariableRecs Then Begin + If ReadFull Then Begin + Len := MaxVariableRecLength; + End Else Begin + Len := VarRecMaxReadLen; + End; + BTGetVariableRecPart ( UsedFileBlock, RR.Ref, DataBuffer^, Len ); + If IsamOK Then LastVarRecLen := Len; + End Else Begin + BTGetRec ( UsedFileBlock, RR.Ref, DataBuffer^, False ); + End; + If Not IsamOK Then Begin + If AskUser And (BTIsamErrorClass = LockError) Then Begin {!!.42mod} + IsamDelay ( DelayTime ); {!!.42mod} + End; {!!.42mod} + End; + Inc (RT); + Until Not AskUser Or (RT > RetriesOnLock) + Or (BTIsamErrorClass <> LockError); + LResult := BTIsamErrorClass; {!!.51} + If LResult = NoError Then Begin {!!.51} + If LongInt (DataBuffer^) <> 0 Then LResult := DialogError; {!!.51} + {-Record is deleted} + End; + BRGetRec := LResult; {!!.51} + End; + + + Function BRLBrowser.BRNextKey ( Var RR : RowRec ) : Integer; + + Var + UseIt : Boolean; + LResult : Integer; {!!.51} + RT : Word; + + Begin + With RR Do Begin + Repeat + RT := 0; + Repeat + If KeyNr = 0 Then Begin {!!.42} + BTNextRecRef ( UsedFileBlock, Ref ); {!!.42} + If IsamError = 10390 Then IsamClearOK; {!!.42} + {-Treat as valid} + End Else Begin {!!.42} + BTNextKey ( UsedFileBlock, KeyNr, Ref, IKS ); + End; {!!.42} + If Not IsamOK Then Begin + If BTIsamErrorClass = LockError Then IsamDelay ( DelayTime ); + End; + Inc (RT); + Until (RT > RetriesOnLock) Or (BTIsamErrorClass <> LockError); + If BTIsamErrorClass <> NoError Then Begin + LResult := BTIsamErrorClass; {!!.51} + End Else Begin + LResult := BRCallFilter ( RR, UseIt ); {!!.51} + End; + Until UseIt Or (LResult <> NoError); {!!.51} + End; + BRNextKey := LResult; {!!.51} + End; + + + Function BRLBrowser.BRPrevKey ( Var RR : RowRec ) : Integer; + + Var + UseIt : Boolean; + LResult : Integer; {!!.51} + RT : Word; + + Begin + With RR Do Begin + Repeat + RT := 0; + Repeat + If KeyNr = 0 Then Begin {!!.42} + BTPrevRecRef ( UsedFileBlock, Ref ); {!!.42} + If IsamError = 10390 Then IsamClearOK; {!!.42} + {-Treat as valid} + End Else Begin {!!.42} + BTPrevKey ( UsedFileBlock, KeyNr, Ref, IKS ); + End; {!!.42} + If Not IsamOK Then Begin + If BTIsamErrorClass = LockError Then IsamDelay ( DelayTime ); + End; + Inc (RT); + Until (RT > RetriesOnLock) Or (BTIsamErrorClass <> LockError); + If BTIsamErrorClass <> NoError Then Begin + LResult := BTIsamErrorClass; {!!.51} + End Else Begin + LResult := BRCallFilter ( RR, UseIt ); {!!.51} + End; + Until UseIt Or (LResult <> NoError); {!!.51} + End; + BRPrevKey := LResult; {!!.51} + End; + + + Function BRLBrowser.BRFindKeyAndRef ( Var RR : RowRec; + NFSD : Integer ) : Integer; + + Var + UseIt : Boolean; + LResult : Integer; {!!.51} + RT : Word; + + Begin + With RR Do Begin + RT := 0; + Repeat + If KeyNr = 0 Then Begin {!!.42} + BTFindRecRef ( UsedFileBlock, Ref, NFSD ); {!!.42} + If IsamError = 10390 Then IsamClearOK; {!!.42} + {-Treat as valid} + End Else Begin {!!.42} + BTFindKeyAndRef ( UsedFileBlock, KeyNr, Ref, IKS, NFSD ); + End; {!!.42} + If Not IsamOK Then Begin + If BTIsamErrorClass = LockError Then IsamDelay ( DelayTime ); + End; + Inc (RT); + Until (RT > RetriesOnLock) Or (BTIsamErrorClass <> LockError); + If BTIsamErrorClass <> NoError Then Begin + LResult := BTIsamErrorClass; {!!.51} + End Else Begin + LResult := BRCallFilter ( RR, UseIt ); {!!.51} + If LResult = NoError Then Begin {!!.51} + If Not UseIt Then Begin + Case NFSD Of + 0: LResult := DialogError; {!!.51} + 1: Begin + LResult := BRNextKey ( RR ); {!!.51} + End; + -1: Begin + LResult := BRPrevKey ( RR ); {!!.51} + End; + End; {Case} + End; + End; + End; + End; + BRFindKeyAndRef := LResult; {!!.51} + End; + + + Function BRLBrowser.BRFindKeyAndRefNoFilter ( Var RR : RowRec; + NFSD : Integer ) + : Integer; + {!!.42} + + Var + RT : Word; + + Begin + With RR Do Begin + RT := 0; + Repeat + If KeyNr = 0 Then Begin {!!.42} + BTFindRecRef ( UsedFileBlock, Ref, NFSD ); {!!.42} + If IsamError = 10390 Then IsamClearOK; {!!.42} + {-Treat as valid} + End Else Begin {!!.42} + BTFindKeyAndRef ( UsedFileBlock, KeyNr, Ref, IKS, NFSD ); + End; {!!.42} + If Not IsamOK Then Begin + If BTIsamErrorClass = LockError Then IsamDelay ( DelayTime ); + End; + Inc (RT); + Until (RT > RetriesOnLock) Or (BTIsamErrorClass <> LockError); + End; + BRFindKeyAndRefNoFilter := BTIsamErrorClass; + End; + + + Function BRLBrowser.BRLLockDetected : Boolean; + + Begin + BRLLockDetected := BTFileBlockIsReadLocked ( UsedFileBlock ) + Or BTFileBlockIsLocked ( UsedFileBlock ); + End; + + + Function BRLBrowser.BRDoReadLock : Integer; + + Var + RT : Word; + + Begin + RT := RetriesOnLock - RetriesOnLock Shr 3; + {-Do only 1/8 of the default retries} + Repeat + BTReadLockFileBlock ( UsedFileBlock ); + If Not IsamOK Then Begin + If BTIsamErrorClass = LockError Then IsamDelay ( DelayTime ); + End; + Inc (RT); + Until (RT > RetriesOnLock) Or (BTIsamErrorClass <> LockError); + BRDoReadLock := BTIsamErrorClass; + End; + + + Function BRLBrowser.BRDoUnLock : Integer; + + Begin + BTUnLockFileBlock ( UsedFileBlock ); + BRDoUnLock := BTIsamErrorClass; + End; + + + Function BRLBrowser.BRSetReadLockUsage ( Var UseRL : Boolean) : Integer; + + Begin + BRSetReadLockUsage := NoError; + {-If fileblock is not valid, UseRL may be fantasy} + UseRL := BTPeekIsNetFileBlock ( UsedFileBlock ); + End; + + + Function BRLBrowser.BRLSaveStatus : Integer; + + Begin + BRLSaveStatus := NoError; + End; + + + Function BRLBrowser.BRLRestoreStatus : Integer; + + Begin + BRLRestoreStatus := NoError; + End; + + + Function BRLBrowser.BRLGetApprKeyAndRef ( RelPos : Word; + Scale : Word; + Var UserKey : GenKeyStr; + Var UserDatRef : LongInt ) + : Integer; + + Begin + If KeyNr = 0 Then Begin {!!.42} + BTGetApprRecRef ( UsedFileBlock, RelPos, Scale, UserDatRef );{!!.42} + End Else Begin {!!.42} + BTGetApprKeyAndRef ( UsedFileBlock, KeyNr, RelPos, Scale, UserKey, + UserDatRef ); + End; {!!.42} + BRLGetApprKeyAndRef := BTIsamErrorClass; + End; + + + Function BRLBrowser.BRLGetApprRelPos ( Var RelPos : Word; + Scale : Word; + UserKey : GenKeyStr; + UserDatRef : LongInt ) + : Integer; + + Begin + If KeyNr = 0 Then Begin {!!.42} + BTGetApprRecPos ( UsedFileBlock, RelPos, Scale, UserDatRef );{!!.42} + End Else Begin {!!.42} + BTGetApprRelPos ( UsedFileBlock, KeyNr, RelPos, Scale, UserKey, + UserDatRef ); + End; {!!.42} + BRLGetApprRelPos := BTIsamErrorClass; + End; + + + Function BRLBrowser.BRLUsedKeys ( Var UK : LongInt ) : Integer; + + Begin + If KeyNr = 0 Then Begin {!!.42} + UK := BTUsedRecs ( UsedFileBlock ); {!!.42} + End Else Begin {!!.42} + UK := BTUsedKeys ( UsedFileBlock, KeyNr ); + End; {!!.42} + BRLUsedKeys := BTIsamErrorClass; + End; diff --git a/src/wc_sdk/browser.inc b/src/wc_sdk/browser.inc new file mode 100644 index 0000000..657023b --- /dev/null +++ b/src/wc_sdk/browser.inc @@ -0,0 +1,1347 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{!!.41 numerous changes made to clean up UseReadLock handling} + + function bKeyPressed : Boolean; + begin + {$IFDEF UseMouse} + if BrowseMouseEnabled then + bKeyPressed := KeyPressed or MousePressed + else + {$ENDIF} + bKeyPressed := KeyPressed; + end; + + function RefreshAtEachCommand(IFBPtr : IsamFileBlockPtr; + KeyNo : Integer) : Boolean; + {-Check for need to refresh before each command if no keystrokes pending} + begin + if bKeyPressed then + RefreshAtEachCommand := False + else + RefreshAtEachCommand := BTOtherWSChangedKey(IFBPtr, KeyNo); + end; + + function RefreshPeriodically(IFBPtr : IsamFileBlockPtr; + KeyNo : Integer) : Boolean; + {-Check for need to refresh every RefreshPeriod clock ticks} + var + Ticks : LongInt absolute $40:$6C; + T : LongInt; + begin + {assume false} + RefreshPeriodically := False; + T := Ticks; + {loop while key not pressed} + while not bKeyPressed do + {is it time to check again?} + if (Ticks-T) >= RefreshPeriod then + {check to see if page stack has been invalidated} + if BTOtherWSChangedKey(IFBPtr, KeyNo) then begin + {we need to refresh the display} + RefreshPeriodically := True; + Exit; + end + else + {save the current tick count} + T := Ticks; + end; + + function CallRefreshFunc(IFBPtr : IsamFileBlockPtr; + KeyNo : Integer) : Boolean; + Inline($FF/$1E/>REFRESHFUNC); {call far dword ptr [>RefreshFunc]} + + function NeedRefresh(IFBPtr : IsamFileBlockPtr; KeyNo : Integer) : Boolean; + {-Return true if screen refresh is needed} + begin + NeedRefresh := False; + if BTIsNetFileBlock(IFBPtr) then + if RefreshFunc <> Nil then + NeedRefresh := CallRefreshFunc(IFBPtr, KeyNo); + end; + + function BrowseI(IFBPtr : IsamFileBlockPtr; + VarRec : Boolean; + KeyNr : Integer; + LowKey, + HighKey : IsamKeyStr; + StartScreenRow, + NrOfRows : Integer; + var DesiredRow : Integer; {!!.05} + var HorizOfs : Integer; {!!.05} + var DatS; + var DatLen : Word; + var Ref : LongInt; + var KeyStr : IsamKeyStr; + var ExitKey : BKtype; + ProcSpecialTask : Pointer; + ProcBuildaRow : Pointer; + ProcDisplayaRow : Pointer) : Integer; + var + Result : Integer; + Moved : Integer; + NewRow : RowRange; + Action : BKtype; + ChWord : Word; + LowRef : LongInt; + HighRef : LongInt; + BrowScreen : BrowScreenType; + bRowsToJump : Integer; + NetUsed : Boolean; + procedure CallBuildaRow(UserRoutine : Pointer; + var RR : RowRec; + KeyNr : Integer; + var DatS; + DatLen : Word); + + procedure CallUserRoutine(var RR : RowRec; + KeyNr : Integer; + var DatS; + DatLen : Word); + {-Call UserRoutine with an action code} + inline($FF/$5E/SearchKeyPtr); {call dword ptr [>SearchKeyPtr]} + + begin + CallUserRoutine(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + end; + + procedure N_Key(IFBPtr : IsamFileBlockPtr; + Key : Integer; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr); + + procedure CallUserRoutine(IFBPtr : IsamFileBlockPtr; + KeyNr : Integer; + var DatRef : LongInt; + var KeyStr : IsamKeyStr; + Net : Boolean); + inline($FF/$1E/>NextKeyPtr); {call dword ptr [>NextKeyPtr]} + + begin + CallUserRoutine(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + end; + + procedure P_Key(IFBPtr : IsamFileBlockPtr; + Key : Integer; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr); + + procedure CallUserRoutine(IFBPtr : IsamFileBlockPtr; + KeyNr : Integer; + var DatRef : LongInt; + var KeyStr : IsamKeyStr; + Net : Boolean); + inline($FF/$1E/>PrevKeyPtr); {call dword ptr [>PrevKeyPtr]} + + begin + CallUserRoutine(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + end; + + procedure F_Key(IFBPtr : IsamFileBlockPtr; + Key : Integer; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr; + NFSD : Integer); + + procedure CallUserRoutine(IFBPtr : IsamFileBlockPtr; + KeyNr : Integer; + var DatRef : LongInt; + var KeyStr : IsamKeyStr; + NFSD : Integer; + Net : Boolean); + inline($FF/$1E/>FindKeyAndRefPtr); {call dword ptr [>FindKeyAndRefPtr]} + + begin + CallUserRoutine(IFBPtr, Key, UserDatRef, UserKey, NFSD, NetUsed); + end; + + function LastRow : Integer; + var + I : Integer; + begin + I := MaxRows; + while (I > 0) and (BrowScreen[I].Ref = LongInt(0)) do + Dec(I); + LastRow := I; + end; + + procedure EmptyBrowScreen; + var + I : Integer; + begin + for I := 1 to MaxRows do + with BrowScreen[I] do begin + IKS := ''; + Ref := LongInt(0); + Row := ''; + end; + end; + + procedure PlaceAtEnd(RR : RowRec); + var + I : Integer; + begin + I := LastRow; + if I < NrOfRows then + BrowScreen[I] := RR + else begin + for I := 1 to NrOfRows-1 do + BrowScreen[I] := BrowScreen[I+1]; + BrowScreen[NrOfRows] := RR; + end; + end; + + procedure PlaceAtTop(RR : RowRec); + var + I : Integer; + begin + for I := NrOfRows downto 2 do + BrowScreen[I] := BrowScreen[I-1]; + BrowScreen[1] := RR; + end; + + procedure ReadLock(On : Boolean); + {!!.41 retry logic removed} + var + IsamSave : Integer; + begin + if UseReadLock then begin + IsamSave := IsamError; + if On then + BTReadLockFileBlock(IFBPtr) + else + BTUnLockFileBlock(IFBPtr); + if IsamSave <> 0 then begin + IsamError := IsamSave; + IsamOK := (IsamError = 0); + end; + end; + end; + + function CompleteaPage : Boolean; + {-Load data records and build display strings for current screen page} + label + ExitPoint; + var + I : Integer; + begin + CompleteaPage := False; + ReadLock(True); + if BTIsamErrorClass > 2 then + Exit; + for I := 1 to NrOfRows do begin + with BrowScreen[I] do begin + if Ref <> LongInt(0) then begin + if (Ref <> LongInt(-1)) and ReadDataRecord then begin + if VarRec then + BTGetVariableRec(IFBPtr, Ref, DatS, DatLen) + else + BTGetRec(IFBPtr, Ref, DatS, False); + if BTIsamErrorClass > 2 then + goto ExitPoint; + end; + if BTIsamErrorClass = 2 then + Ref := LongInt(-1); + CallBuildaRow(ProcBuildaRow, BrowScreen[I], KeyNr, DatS, DatLen); + end; + end; + end; + CompleteaPage := True; +ExitPoint: + ReadLock(False); + end; + + procedure DisplayaPage; + var + I : Integer; + {$IFDEF UseMouse} + SaveMouseEn : Boolean; + {$ENDIF} + begin + {$IFDEF UseMouse} + SaveMouseEn := BrowseMouseEnabled; + BrowseMouseEnabled := False; + if SaveMouseEn then + HideMouse; + {$ENDIF} + for I := 1 to NrOfRows do + with BrowScreen[I] do + CallDisplayaRow(ProcDisplayaRow, BrowScreen[I], KeyNr, I, + StartScreenRow, (I = CurRow), HorizOfs); + {$IFDEF UseMouse} + BrowseMouseEnabled := SaveMouseEn; + if BrowseMouseEnabled then + ShowMouse; + {$ENDIF} + end; + + function BuildFirstPage : Integer; + label + ExitPoint; + var + I : Integer; + TRec : RowRec; + begin + BuildFirstPage := 2; + ReadLock(True); + if BTIsamErrorClass > 2 then + Exit; + with TRec do begin + IKS := LowKey; + S_Key(IFBPtr, KeyNr, Ref, IKS); + if BTIsamErrorClass > 1 then begin + goto ExitPoint; + end; + end; + if (BTIsamErrorClass = 1) or (not KeyInBounds(TRec.IKS)) then begin + BuildFirstPage := 1; + goto ExitPoint; + end; + I := 1; + while (I <= NrOfRows) and (KeyInBounds(TRec.IKS)) and + (BTIsamErrorClass = 0) do begin + BrowScreen[I] := TRec; + with TRec do begin + Inc(I); + if I <= NrOfRows then begin + N_Key(IFBPtr, KeyNr, Ref, IKS); + if BTIsamErrorClass > 1 then + goto ExitPoint; + end; + end; + end; + BuildFirstPage := 0; +ExitPoint: + ReadLock(False); + end; + + function BuildLastPage : Integer; + label + ExitPoint; + var + I : Integer; + TRec : RowRec; + begin + BuildLastPage := 2; + ReadLock(True); + if BTIsamErrorClass > 2 then + Exit; + with TRec do begin + IKS := HighKey; + while Length(IKS) < MaxKeyLen do + IKS := IKS+#255; + Ref := $0FFFFFFF; + F_Key(IFBPtr, KeyNr, Ref, IKS, -1); + if BTIsamErrorClass > 1 then + goto ExitPoint; + end; + if (BTIsamErrorClass = 1) or (not KeyInBounds(TRec.IKS)) then begin + BuildLastPage := 1; + goto ExitPoint; + end; + I := 1; + while (I <= NrOfRows) and (KeyInBounds(TRec.IKS)) and (BTIsamErrorClass = 0) do begin + PlaceAtTop(TRec); + with TRec do begin + Inc(I); + if I <= NrOfRows then begin + P_Key(IFBPtr, KeyNr, Ref, IKS); + if BTIsamErrorClass > 1 then + goto ExitPoint; + end; + end; + end; + BuildLastPage := 0; +ExitPoint: + ReadLock(False); + end; + + function BuildSpecPage(Desired : Integer) : Integer; + var + I, J : Integer; + TRec : RowRec; + begin + BuildSpecPage := 2; + EmptyBrowScreen; + TRec.Ref := Ref; + TRec.IKS := KeyStr; + with TRec do + F_Key(IFBPtr, KeyNr, Ref, IKS, 1); + case BTIsamErrorClass of + 0 : if not KeyInBounds(TRec.IKS) then begin {!!.07} + TRec.Ref := Ref; {!!.07} + TRec.IKS := KeyStr; {!!.07} + with TRec do {!!.07} + F_Key(IFBPtr, KeyNr, Ref, IKS, -1); {!!.07} + if (not IsamOK) or (not KeyInBounds(TRec.IKS)) then begin {!!.07} {!!.40} + BuildSpecPage := 1; {!!.07} + Exit; {!!.07} + end; {!!.07} + end; {!!.07} + 1 : if IsamError = 10250 then begin + TRec.Ref := Ref; + TRec.IKS := KeyStr; + with TRec do + F_Key(IFBPtr, KeyNr, Ref, IKS, -1); + if not IsamOK then begin {!!.06} + BuildSpecPage := 1; {!!.06} + Exit; {!!.06} + end; {!!.06} + end + else begin + with TRec do + N_Key(IFBPtr, KeyNr, Ref, IKS); + if not IsamOK then begin + BuildSpecPage := 1; + Exit; + end; + end; + else Exit; + end; + I := Desired; + while (I >= 1) and KeyInBounds(TRec.IKS) and (BTIsamErrorClass = 0) do begin + BrowScreen[I] := TRec; + Dec(I); + with TRec do + if I > 0 then begin + P_Key(IFBPtr, KeyNr, Ref, IKS); + if BTIsamErrorClass > 1 then + Exit; + end; + end; + if I > 0 then begin + Move(BrowScreen[Succ(I)], BrowScreen[1], + SizeOf(RowRec) * (Desired - I)); + for J := Desired downto Succ(Desired-I) do + FillChar(BrowScreen[J], SizeOf(RowRec), 0); + Dec(Desired, I); + end; + if Desired = 0 then + Desired := 1; + if Desired < NrOfRows then begin + F_Key(IFBPtr, KeyNr, Ref, KeyStr, 1); + if BTIsamErrorClass > 1 then + Exit; + if BTIsamErrorClass = 0 then begin + with TRec do + N_Key(IFBPtr, KeyNr, Ref, IKS); + I := Succ(Desired); + while (I <= NrOfRows) and KeyInBounds(TRec.IKS) and (BTIsamErrorClass = 0) do + begin + BrowScreen[I] := TRec; + Inc(I); + if I <= NrOfRows then + with TRec do + N_Key(IFBPtr, KeyNr, Ref, IKS); + end; + end + else + I := Desired; + if Desired > I then + CurRow := I + else + CurRow := Desired; + end; + BuildSpecPage := 0; + end; + + function BuildPrevPage(Nr : Integer; var Moved : Integer) : Integer; + label + ExitPoint; + var + I : Integer; + Res : Integer; + TRec : RowRec; + begin + BuildPrevPage := 2; + ReadLock(True); + if BTIsamErrorClass > 2 then + Exit; + + Moved := 0; + if BrowScreen[1].Ref = LongInt(0) then begin + BuildPrevPage := 1; + goto ExitPoint; + end; + TRec := BrowScreen[1]; + with TRec do begin + F_Key(IFBPtr, KeyNr, Ref, IKS, 0); + if BTIsamErrorClass > 1 then + goto ExitPoint; + if BTIsamErrorClass = 1 then + F_Key(IFBPtr, KeyNr, Ref, IKS, -1) + else + P_Key(IFBPtr, KeyNr, Ref, IKS); + end; + case BTIsamErrorClass of + 0 : ; + 1 : begin + KeyStr := BrowScreen[1].IKS; + Ref := BrowScreen[1].Ref; + BuildPrevPage := BuildSpecPage(1); + goto ExitPoint; + end; + else + goto ExitPoint; + end; + I := 1; + while (I <= Nr) and (KeyInBounds(TRec.IKS)) and (BTIsamErrorClass = 0) do begin + PlaceAtTop(TRec); + with TRec do begin + Inc(I); + if I <= Nr then begin + P_Key(IFBPtr, KeyNr, Ref, IKS); + if BTIsamErrorClass > 1 then + goto ExitPoint; + end; + end; + end; + Moved := I-1; + + BuildPrevPage := 0; +ExitPoint: + ReadLock(False); + end; + + function BuildNextPage(Nr : Integer; var Moved : Integer) : Integer; + label + ExitPoint; + var + I : Integer; + TRec : RowRec; + begin + BuildNextPage := 2; + ReadLock(True); + if BTIsamErrorClass > 2 then + Exit; + Moved := 0; + I := LastRow; + if I = 0 then begin + BuildNextPage := 1; + goto ExitPoint; + end; + TRec := BrowScreen[I]; + with TRec do begin + F_Key(IFBPtr, KeyNr, Ref, IKS, 0); + if BTIsamErrorClass > 1 then + goto ExitPoint; + N_Key(IFBPtr, KeyNr, Ref, IKS); + end; {!!.06} + case BTIsamErrorClass of + 0 : ; + 1 : begin + KeyStr := BrowScreen[I].IKS; + Ref := BrowScreen[I].Ref; + BuildNextPage := BuildSpecPage(I); + goto ExitPoint; + end; + else + goto ExitPoint; + end; + + I := 1; + while (I <= Nr) and (KeyInBounds(TRec.IKS)) and (BTIsamErrorClass = 0) do begin + PlaceAtEnd(TRec); + with TRec do begin + Inc(I); + if I <= Nr then begin + N_Key(IFBPtr, KeyNr, Ref, IKS); + if BTIsamErrorClass > 1 then + goto ExitPoint; + end; + end; + end; + BuildNextPage := 0; + Moved := I-1; +ExitPoint: + ReadLock(False); + end; + + function BuildThisPage(K : IsamKeyStr; R : LongInt) : Integer; + label + ExitPoint; + var + I : Integer; + FreeRows : Integer; + SaveUseReadLock : Boolean; + TRec : RowRec; + begin + BuildThisPage := 2; + ReadLock(True); + if BTIsamErrorClass > 2 then + Exit; + SaveUseReadLock := UseReadLock; + UseReadLock := False; + with TRec do begin + IKS := K; + Ref := R; + F_Key(IFBPtr, KeyNr, Ref, IKS, -1); + if BTIsamErrorClass > 1 then + goto ExitPoint; + if (BTIsamErrorClass = 1) or (not KeyInBounds(IKS)) then begin + N_Key(IFBPtr, KeyNr, Ref, IKS); + if (BTIsamErrorClass = 1) or (not KeyInBounds(IKS)) then begin + BuildThisPage := 1; + goto ExitPoint; + end; + end; + end; + I := 1; + while (I <= NrOfRows) and (KeyInBounds(TRec.IKS)) and (BTIsamErrorClass = 0) do begin + BrowScreen[I] := TRec; + with TRec do begin + Inc(I); + if I <= NrOfRows then begin + N_Key(IFBPtr, KeyNr, Ref, IKS); + if BTIsamErrorClass > 1 then + goto ExitPoint; + end; + end; + end; + CurRow := 1; + FreeRows := NrOfRows-LastRow; + if FreeRows > 0 then begin + if BuildPrevPage(FreeRows, Moved) > 1 then + goto ExitPoint; + CurRow := Moved+1; + end; + BuildThisPage := 0; + UseReadLock := SaveUseReadLock; +ExitPoint: + ReadLock(False); + end; + + function ActSpecPage(Desired : Integer) : Integer; + begin + ActSpecPage := 2; + ReadLock(True); + if BTIsamErrorClass > 2 then {!!.06} + Exit; + Result := BuildSpecPage(Desired); + ReadLock(False); + if Result <> 0 then begin + ActSpecPage := Result; + Exit; + end; + if not CompleteaPage then begin + ActSpecPage := 2; + Exit; + end; + DisplayaPage; + ActSpecPage := 0; + end; + + function ActCurPage(Repos : Boolean) : Integer; + var + SaveRow : Integer; + begin + SaveRow := CurRow; + EmptyBrowScreen; + Result := BuildThisPage(KeyStr, Ref); + if Result <> 0 then begin + ActCurPage := Result; + Exit; + end; + if Repos then + if SaveRow > CurRow then begin + Result := BuildPrevPage(SaveRow-CurRow, Moved); + if Result <> 0 then begin + ActCurPage := Result; + Exit; + end; + inc(CurRow, Moved); + end; + if not CompleteaPage then begin + ActCurPage := 2; + Exit; + end; + DisplayaPage; + ActCurPage := 0; + end; + + function FindLowHighKeys(var LowKey : IsamKeyStr; + var LowRef : LongInt; + var HighKey : IsamKeyStr; + var HighRef : LongInt) : Integer; + {-Return lowest and highest record numbers} + var + Result : Integer; + begin + S_Key(IFBPtr, KeyNr, LowRef, LowKey); + if BTIsamErrorClass > 1 then begin + FindLowHighKeys := 2; + Exit; + end; + if (BTIsamErrorClass = 1) or not KeyInBounds(LowKey) then begin + FindLowHighKeys := 1; + Exit; + end; + while Length(HighKey) < MaxKeyLen do + HighKey := HighKey+#255; + HighRef := $0FFFFFFF; + F_Key(IFBPtr, KeyNr, HighRef, HighKey, -1); + if BTIsamErrorClass > 1 then begin + FindLowHighKeys := 2; + Exit; + end; + if (BTIsamErrorClass = 1) or not KeyInBounds(HighKey) then begin + FindLowHighKeys := 1; + Exit; + end; + FindLowHighKeys := 0; + end; + + function FindLowHighRows(var LowRef, HighRef : LongInt) : Integer; + {-Return lowest and highest record numbers} + var + Result : Integer; + IKS1,IKS2 : IsamKeyStr; + begin + IKS1 := LowKey; + IKS2 := HighKey; + FindLowHighRows := FindLowHighKeys(IKS1, LowRef, IKS2, HighRef); + end; + + {$IFDEF UseMouse} + procedure DoMouseScale; + {-Determine effect of LowKey and HighKey on scroll bar scaling} + var + LK, HK : IsamKeyStr; + begin + LK := LowKey; + HK := HighKey; + if FindLowHighKeys(LK, LowRef, HK, HighRef) <> 0 then + Exit; + if Length(LowKey) = 0 then + MouseLowScale := 0 + else + BTGetApprRelPos(IFBPtr, KeyNr, MouseLowScale, MouseScale, LK, LowRef); + if HighKey = #255 then + MouseHighScale := MouseScale + else + BTGetApprRelPos(IFBPtr, KeyNr, MouseHighScale, MouseScale, HK, HighRef); + end; + + function MouseRescale(Position, RelScale : Word) : Word; + {-Recompute scroll bar position taking into account any scaling} + var + Scale : Word; + + begin + if AutoScaleMouse then begin + if not NoNetMode then + DoMouseScale; + Scale := MouseHighScale - MouseLowScale; + Position := Position - MouseLowScale; + end + else + Scale := MouseScale; + {calculate slider position} + if Scale = 0 then {protect against div by zero} + MouseRescale := 0 + else + MouseRescale := Word((LongInt(Position) * RelScale) div Scale); + end; + + function MouseRescale2(Position, RelScale : LongInt) : Word; + {-Recompute scroll bar position taking into account any scaling} + + begin + if RelScale = 0 then {protect against div by zero} + RelScale := 1; + {calculate slider position} + if AutoScaleMouse then begin + if not NoNetMode then + DoMouseScale; + MouseRescale2 := Word(((LongInt(Position) * + (MouseHighScale - MouseLowScale)) div + RelScale) + MouseLowScale); + end + else + MouseRescale2 := Word((LongInt(Position) * MouseScale) div RelScale); + end; + + procedure EvaluateSliderPos(var RR : RowRec); + {-Decide where the scroll bar slider should be postioned} + var + RelPos : Word; + Ht : Word; + begin + if not UseScrollBar then + Exit; + Ht := ScrollBarHt; + with RR do + BTGetApprRelPos(IFBPtr, KeyNr, RelPos, MouseScale, IKS, Ref); + if not IsamOK then + Exit; + RelPos := MouseRescale(RelPos, ScrollBarHt); + SliderPos := RelPos + ScrollBarTop; + if SliderPos > ScrollBarBot then + SliderPos := ScrollBarBot; + end; + + procedure EvaluateMousePosition(var KeyStr : IsamKeyStr; + var Ref : LongInt; + var Cmd : BKtype; var CurRow : RowRange); + {-Evaluate mouse command based on position} + var + mX : Byte; {Mouse absolute X position} + mY : Byte; {Mouse absolute Y position} + mCol : Word; {Logical column where mouse is located} + Posit : Word; + procedure CallUserMouseRoutine(X, Y : Byte; var Cmd : BKtype); + inline($FF/$1E/>UserMousePtr); {call dword ptr [>UserMousePtr]} + + begin + if BrowseMouseEnabled then begin + RepositionDesired := False; + {Compute absolute mouse coordinates} + mX := MouseXLo+MouseKeyWordX; + mY := MouseYLo+MouseKeyWordY; + if mX = ScrollBarCol then begin + if mY = ScrollBarUp then + {mouse cursor on top arrow} + Cmd := MouseUpCmd[BrowseMousePage] + else if mY = ScrollBarDn then + {mouse cursor on bottom arrow} + Cmd := MouseDownCmd[BrowseMousePage] + else if UseScrollBar and + (mY >= ScrollBarTop) and (mY <= ScrollBarBot) then begin + {mouse cursor on scroll bar} + SliderPos := mY; + if mY = ScrollBarTop then + Cmd := BKfirstRec + else if mY = ScrollBarBot then + Cmd := BKlastRec + else begin + Dec(mY, ScrollBarTop); + Posit := MouseRescale2(mY, ScrollBarHt); + BTGetApprKeyAndRef(IFBPtr, KeyNr, + Posit, + MouseScale, + KeyStr, + Ref); + if not IsamOK then + Exit; + RepositionDesired := True; {force repositioning} + Cmd := BKRedraw; {force redraw} + end; + end + else if UserMousePtr <> Nil then + {outside browser's scroll bar, call user mouse routine} + CallUserMouseRoutine(mX, mY, Cmd); + end + else if (mY >= BrowseYL) and (mY <= BrowseYH) and {!!.06} + (mX >= MouseX1) and (mX <= MouseX2) then begin {!!.06} + {in active browser region, convert to window-relative} + Dec(mY, Pred(BrowseYL)); + if mY = CurRow then + Cmd := BKenter + else + if BrowScreen[mY].Ref <> 0 then begin + CurRow := mY; + Cmd := BKplus; + end; + end + else if UserMousePtr <> Nil then + {outside browser, call user mouse routine} + CallUserMouseRoutine(mX, mY, Cmd); + end; + end; + {$ENDIF} + + {$IFDEF UseMouse} + var + SaveMouseEnabled : Boolean; + {$ENDIF} + begin {BrowseI} + if (DesiredRow < 0) or (DesiredRow > NrOfRows) then + DesiredRow := 0; + gHighKey := HighKey; {!!.22} + gLowKey := LowKey; {!!.22} + if not KeyInBounds(KeyStr) then begin {!!.06} + if KeyStr < LowKey then + KeyStr := LowKey + else + KeyStr := HighKey; + DesiredRow := 0; {!!.06} + end; {!!.06} + + if NrOfRows > MaxRows then + NrOfRows := MaxRows + else if NrOfRows < MinRows then + NrOfRows := MinRows; + if (RowsToJump = 0) or (RowsToJump > NrOfRows) then + bRowsToJump := NrOfRows div 2 + else + bRowsToJump := RowsToJump; + + if NoNetMode then begin + {Determine first and last acceptable records} + Result := FindLowHighRows(LowRef, HighRef); + if Result <> 0 then begin + BrowseI := Result; + Exit; + end; + {$IFDEF UseMouse} + if BrowseMouseEnabled and UseScrollBar then begin + DoMouseScale; + end; + {$ENDIF} + end; + {$IFDEF UseMouse} + SaveMouseEnabled := BrowseMouseEnabled; + BrowseMouseEnabled := False; + {$ENDIF} + + if DesiredRow = 0 then begin + CurRow := 1; + Result := ActCurPage(False); + if Result <> 0 then begin + BrowseI := Result; + {$IFDEF UseMouse} {!!.22} + BrowseMouseEnabled := SaveMouseEnabled; {!!.22} + {$ENDIF} {!!.22} + Exit; + end; + end + else begin + CurRow := DesiredRow; + Result := ActSpecPage(DesiredRow); + if Result <> 0 then begin + BrowseI := Result; + {$IFDEF UseMouse} {!!.22} + BrowseMouseEnabled := SaveMouseEnabled; {!!.22} + {$ENDIF} {!!.22} + Exit; + end; + end; + {$IFDEF UseMouse} + PrevSlid := 0; + BrowseMouseEnabled := SaveMouseEnabled; + if BrowseMouseEnabled then begin + if UseScrollBar then begin + EvaluateSliderPos(BrowScreen[CurRow]); + {Update slider in frame} + FastWrite(ScrollMark, SliderPos, ScrollBarCol, SliderAttr); {!!.41} + PrevSlid := SliderPos; + end; + ShowMouse; + end; + {$ENDIF} + + CallDisplayaRow(ProcDisplayaRow, BrowScreen[CurRow], KeyNr, CurRow, + StartScreenRow, False, HorizOfs); + + BrowseI := 2; + Action := ExitKey; + repeat + DesiredRow := CurRow; + + {$IFDEF UseMouse} + if Action = BKprobe then begin + NewRow := CurRow; + + EvaluateMousePosition(KeyStr, Ref, Action, NewRow); + if Action = BKprobe then + Action := BKnone; + if NewRow <> CurRow then begin + CallDisplayaRow(ProcDisplayaRow, + BrowScreen[CurRow], KeyNr, CurRow, + StartScreenRow, False, HorizOfs); + CurRow := NewRow; + end; + end; + {$ENDIF} + case Action of + BKRowEnd : + begin + HorizOfs := MaxInt; + Action := BKredraw; + Ref := BrowScreen[CurRow].Ref; + KeyStr := BrowScreen[CurRow].IKS; + end; + BKRowBegin : + begin + HorizOfs := 0; + Action := BKredraw; + Ref := BrowScreen[CurRow].Ref; + KeyStr := BrowScreen[CurRow].IKS; + end; + end; + + case Action of + BKnone, + BKchar : ; + BKfirstRec : + {!!} + if not NoNetMode or (BrowScreen[1].Ref <> LowRef) then begin + CurRow := 1; + EmptyBrowScreen; + Result := BuildFirstPage; + if Result <> 0 then begin + BrowseI := Result; + Exit; + end; + if not CompleteaPage then + Exit; + DisplayaPage; + end + else begin + CallDisplayaRow(ProcDisplayaRow, BrowScreen[CurRow], KeyNr, CurRow, + StartScreenRow, False, HorizOfs); + CurRow := 1; + end; + + BKlastRec : + {!!} + if not NoNetMode or (BrowScreen[LastRow].Ref <> HighRef) then begin + CurRow := LastRow; + EmptyBrowScreen; + Result := BuildLastPage; + if Result <> 0 then begin + BrowseI := Result; + Exit; + end; + if not CompleteaPage then + Exit; + DisplayaPage; + end + else begin + CallDisplayaRow(ProcDisplayaRow, BrowScreen[CurRow], KeyNr, CurRow, + StartScreenRow, False, HorizOfs); + CurRow := LastRow; + end; + + BKpageUp : + {!!} + if not NoNetMode or (BrowScreen[1].Ref <> LowRef) then begin + Result := BuildPrevPage(NrOfRows, Moved); + if Result <> 0 then begin + BrowseI := Result; + Exit; + end; + if Moved = 0 then {!!.40} + CurRow := 1; {!!.40} + if not CompleteaPage then + Exit; + DisplayaPage; + end + else begin + CallDisplayaRow(ProcDisplayaRow, BrowScreen[CurRow], KeyNr, CurRow, + StartScreenRow, False, HorizOfs); + CurRow := 1; + end; + + BKpageDown : + {!!} + if not NoNetMode or (BrowScreen[LastRow].Ref <> HighRef) then begin + Result := BuildNextPage(NrOfRows, Moved); + if Result <> 0 then begin + BrowseI := Result; + Exit; + end; + if Moved = 0 then + CurRow := LastRow; + if not CompleteaPage then + Exit; + DisplayaPage; + end + else begin + CallDisplayaRow(ProcDisplayaRow, BrowScreen[CurRow], KeyNr, CurRow, + StartScreenRow, False, HorizOfs); + CurRow := LastRow; + end; + + BKup : + {!!} + if CurRow = 1 then begin + if not NoNetMode or (BrowScreen[CurRow].Ref <> LowRef) then begin + Result := BuildPrevPage(bRowsToJump, Moved); + if Result <> 0 then begin + BrowseI := Result; + Exit; + end; + if Moved <> 0 then + CurRow := Moved; + if not CompleteaPage then + Exit; + DisplayaPage; + end; + end + else begin + CallDisplayaRow(ProcDisplayaRow, BrowScreen[CurRow], KeyNr, CurRow, + StartScreenRow, False, HorizOfs); + Dec(CurRow); + end; + + BKdown : + {!!} + if CurRow = LastRow then begin + if not NoNetMode or (BrowScreen[CurRow].Ref <> HighRef) then begin + Result := BuildNextPage(bRowsToJump, Moved); + if Result <> 0 then begin + BrowseI := Result; + Exit; + end; + if Moved <> 0 then + CurRow := LastRow+1-Moved; + if not CompleteaPage then + Exit; + DisplayaPage; + end; + end + else begin + CallDisplayaRow(ProcDisplayaRow, BrowScreen[CurRow], KeyNr, CurRow, + StartScreenRow, False, HorizOfs); + Inc(CurRow); + end; + + BKleft : + if HorizOfs > 0 then begin + Dec(HorizOfs); + DisplayaPage; + end; + + BKright : + begin + HorizOfs := (HorizOfs+1) mod 32000; + DisplayaPage; + end; + + BKplus : + begin + Ref := BrowScreen[CurRow].Ref; + KeyStr := BrowScreen[CurRow].IKS; + Result := ActCurPage(True); + if Result <> 0 then begin + BrowseI := Result; + Exit; + end; + end; + + BKhelp : + if BrowseHelpPtr <> nil then + HelpRoutine(HelpForBrowse, IFBptr, BrowseHelpIndex); + + BKquit : + begin + ExitKey := BKquit; + BrowseI := 0; + Exit; + end; + + BKenter, BKuser0..BKuser9 : + begin + {!!.41 this block reorganized} + ExitKey := Action; + Ref := BrowScreen[CurRow].Ref; + KeyStr := BrowScreen[CurRow].IKS; + if Ref = LongInt(-1) then begin + {Attempting to select a known-locked row} + IsamError := 10399; + IsamOK := False; + end else begin + {Row wasn't locked last time browser page was built} + if VarRec then + BTGetVariableRec(IFBPtr, Ref, DatS, DatLen) + else + BTGetRec(IFBPtr, Ref, DatS, False); + if IsamOK then + if LongInt(DatS) <> 0 then begin + {Record was deleted by another station} + IsamError := 8102; + IsamOK := False; + end else + {Everything is ok} + BrowseI := 0; + end; + Exit; + end; + end; + + if Action <> BKRedraw then + CallDisplayaRow(ProcDisplayaRow, BrowScreen[CurRow], KeyNr, CurRow, + StartScreenRow, True, HorizOfs); + + case Action of + BKRedraw : + begin + if RepositionDesired then + Result := ActCurPage(True) + else + Result := ActSpecPage(CurRow); + if Result <> 0 then begin + BrowseI := Result; + Exit; + end; + Action := BKNone; + end; + BKtask0..BKtask9 : + if ProcSpecialTask <> nil then begin + ExitKey := Action; + Ref := BrowScreen[CurRow].Ref; + if Ref <> LongInt(-1) then begin + if VarRec then + BTGetVariableRec(IFBPtr, Ref, DatS, DatLen) + else + BTGetRec(IFBPtr, Ref, DatS, False); + if BTIsamErrorClass > 2 then + Exit; + + if (LongInt(DatS) <> LongInt(0)) or (BTIsamErrorClass = 2) then begin + Ref := BrowScreen[CurRow].Ref; + KeyStr := BrowScreen[CurRow].IKS; + CallDisplayaRow(ProcDisplayaRow, BrowScreen[CurRow], KeyNr, CurRow, + StartScreenRow, False, HorizOfs); + Result := ActCurPage(True); + if Result <> 0 then begin + BrowseI := Result; + Exit; + end; + CallDisplayaRow(ProcDisplayaRow, BrowScreen[CurRow], KeyNr, CurRow, + StartScreenRow, True, HorizOfs); + Action := BKnone; + end + else begin + KeyStr := BrowScreen[CurRow].IKS; + CallSpecialTask(ProcSpecialTask, IFBPtr, DatS, Ref, KeyStr, KeyNr, + Action, Result, DatLen); + if Result <> 0 then begin + BrowseI := Result; + Exit; + end; + Result := ActCurPage(True); + if Result <> 0 then begin + BrowseI := Result; + Exit; + end; + end; + end + else + Action := BKnone; + end; + else begin + {$IFDEF UseMouse} + if BrowseMouseEnabled and UseScrollBar then begin + EvaluateSliderPos(BrowScreen[CurRow]); + {Update slider in frame} + if SliderPos <> PrevSlid then begin + HideMouse; + if PrevSlid <> 0 then + FastWrite(ScrollVertChar, PrevSlid, ScrollBarCol, ScrollBarAttr); + FastWrite(ScrollMark, SliderPos, ScrollBarCol, SliderAttr); {!!.41} + PrevSlid := SliderPos; + ShowMouse; + end; + end; + {$ENDIF} + if NeedRefresh(IFBPtr, KeyNr) then + Action := BKPlus + else + Action := GetCommand(BrowseKeySet, BrowseKeyPtr, ChWord); + end; + end; + + (* !! removed by KRK, 9/23/88 + CallDisplayaRow(ProcDisplayaRow, BrowScreen[CurRow], KeyNr, CurRow, + StartScreenRow, False, HorizOfs); + *) + until False; + end; diff --git a/src/wc_sdk/browser.pas b/src/wc_sdk/browser.pas new file mode 100644 index 0000000..f75201c --- /dev/null +++ b/src/wc_sdk/browser.pas @@ -0,0 +1,916 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$F+,V-,B-,S-,I-,R-} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} +{$IFDEF CanSetOvrflowCheck} + {$Q-} +{$ENDIF} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit Browser; + +interface + +{won't work under Windows} +{$IFDEF Windows} + **ERROR** Not compatible with Turbo Pascal for Windows +{$ENDIF} + +{If using Turbo Professional or Object Professional, pull in ??DEFINE.INC + for UseMouse conditional} + +{$IFDEF UseTPCRT} + {$I tpdefine.inc} +{$ENDIF} + +{$IFDEF UseOPCRT} + {$I opdefine.inc} +{$ENDIF} + +uses + TpCmd, + + {the following set of conditionals controls which CRT unit is linked in. + It also controls if a mouse unit is pulled in.} + + {$IFNDEF UseOPCRT} + {$IFDEF UseTPCRT} + TpCrt, + {$IFDEF UseMouse} + TpMouse, + {$ENDIF} + {$ELSE} + Crt, + {$ENDIF} + {$ELSE} + OpCrt, + {$IFDEF UseMouse} + OpMouse, + {$ENDIF} + {$ENDIF} + Dos, + BTBase, + BTIsBase, + Filer, + VRec; + +const + MinRows = 4; {Minimum number of usable lines on the screen} + MaxRows = 20; {Maximum number of usable lines on the screen} + MaxCols = 128; {Number of usable columns on screen, must be <= 255} + + {Number of retries for a read operation in case of a Lock-Error} + RetriesOnLock : Integer = 50; + + {True lets browser go to disk less often, safe only for single user mode} + NoNetMode : Boolean = False; + + {If True, Browser will use read locks while building its pages} + UseReadLock : Boolean = False; + + {If False, the data record will not be read prior to calling BuildARow} + ReadDataRecord : Boolean = True; + +var + BrowseYL : Byte; + BrowseYH : Byte; + +type + RowRec = + record + IKS : IsamKeyStr; + Ref : LongInt; + Row : string[MaxCols]; + end; + {Basic type of the browser. The browser is used in three steps: + 1) and are allocated. + 2) (procedure parameter) determines the row. + 3) (procedure parameter) puts on the screen} + + {----------------- programmer's hooks -------------} +var + BrowseKeyPtr : Pointer; {pointer to routine to return next keystroke} + BrowseHelpPtr : Pointer; {pointer to routine to display help} + BrowseHelpIndex : Word; {current help topic} + + {.F-} +const + BKnone = 00; {Not a command} + BKchar = 01; {Regular character--not a command} + BKenter = 02; {Select} + BKquit = 03; {Escape} + BKfirstRec = 04; {Cursor to first record} + BKlastRec = 05; {Cursor to last record} + BKleft = 06; {Cursor left one column} + BKright = 07; {Cursor right one column} + BKup = 08; {Cursor up one row} + BKdown = 09; {Cursor down one row} + BKpageUp = 10; {Cursor up one page} + BKpageDown = 11; {Cursor down one page} + BKplus = 12; {Reread current record} + BKhelp = 13; {Invoke help routine} + BKredraw = 14; {redraw the browse screen} + BKprobe = 15; {signals a mouse event} + BKRowEnd = 16; {command to go to end of row} + BKRowBegin = 17; {comamnd to go to start of row} + + BKtask0 = 18; {user-defined task commands} + BKtask1 = 19; + BKtask2 = 20; + BKtask3 = 21; + BKtask4 = 22; + BKtask5 = 23; + BKtask6 = 24; + BKtask7 = 25; + BKtask8 = 26; + BKtask9 = 27; + BKuser0 = 28; {user-defined exit commands} + BKuser1 = 29; + BKuser2 = 30; + BKuser3 = 31; + BKuser4 = 32; + BKuser5 = 33; + BKuser6 = 34; + BKuser7 = 35; + BKuser8 = 36; + BKuser9 = 37; + +type + BKtype = BKnone..BKuser9; +const + {$IFDEF UseTPCRT} + HelpForBrowse = TpCrt.HelpForXXXX2; {= 7} + {$ELSE} + {$IFDEF UseOPCRT} + HelpForBrowse = 99; + {$ELSE} + HelpForBrowse = 7; + {$ENDIF} + {$ENDIF} + + {Keystroke to command mapping} + BrowseKeyMax = 200; {last available slot in BrowseKeySet} + + {ID string for installation programs} + BrowseKeyID : string[17] = 'browser key array'; + + {default key assignments} + BrowseKeySet : array[0..BrowseKeyMax] of Byte = ( + {length keys command type key sequence} + 3, $00, $00, BKquit, {^Break} + 3, $00, $3B, BKhelp, {F1} + 3, $00, $47, BKfirstRec, {Home} + 3, $00, $48, BKup, {Up} + 3, $00, $49, BKpageUp, {PgUp} + 3, $00, $4B, BKleft, {Left} + 3, $00, $4D, BKright, {Right} + 3, $00, $4F, BKlastRec, {End} + 3, $00, $50, BKdown, {Down} + 3, $00, $51, BKpageDown, {PgDn} + 3, $00, $76, BKlastrec, {^PgDn} + 3, $00, $84, BKfirstrec, {^PgUp} + 2, $03, BKpageDown, {^C} + 2, $04, BKright, {^D} + 2, $05, BKup, {^E} + 2, $0D, BKenter, {^M, Enter} + 2, $12, BKpageUp, {^R} + 2, $13, BKleft, {^S} + 2, $17, BKup, {^W} + 2, $18, BKdown, {^X} + 2, $1A, BKdown, {^Z} + 2, $1B, BKquit, {Esc} + 2, $2B, BKplus, {+} + 3, $11, $03, BKlastrec, {^Q^C} + 3, $11, $12, BKfirstrec, {^Q^R} + {-----------pad to end of array----------} + {$IFDEF UseMouse} + 3, $00, $EF, BKprobe, {Click left} + 3, $00, $EE, BKquit, {Click right} + 3, $00, $ED, BKhelp, {Click both} + {$ELSE} + 0, 0, {90} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {100} + {$ENDIF} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {110} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {120} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {130} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {140} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {150} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {160} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {170} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {180} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {190} + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); {200} +{.F+} + + RowsToJump : Integer = 0; + + {$IFDEF UseMouse} + {Mouse control for Browser} + BrowseMouseEnabled : Boolean = False; {True if mouse is enabled} + ScrollBarAttr : Byte = $07; + SliderAttr : Byte = $0F; + MouseUpMark : Char = #24; {Characters in scroll bar} + MouseDnMark : Char = #25; + ScrollMark : Char = #178; + ScrollVertChar : Char = #176; + UserMousePtr : Pointer = Nil; {Hot spot action routine} + BrowseMousePage : Boolean = False; {True to scroll by one page per click} + AutoScaleMouse : Boolean = True; {Adjust for LowKey and HighKey} + UseScrollBar : Boolean = True; {True to use scroll bars if mouse installed} + ScrollBarAutoSize : Boolean = True; {True to match bar to window height} + ScrollBarUp : Byte = 1; {relative location of the up arrow} + ScrollBarHt : Byte = 18; {the height of bar, excluding the arrows} + ScrollBarCol : Byte = 80; {absolute column for scroll bar} + MouseX1 : Byte = 1; {Left margin for mouse select} {!!.06} + MouseX2 : Byte = 79; {Right margin for mouse select} {!!.06} + {$ENDIF} + + RefreshFunc : Pointer = Nil; {Ptr to refresh function} {!!.06} + +function Browse(IFBPtr : IsamFileBlockPtr; + VarRec : Boolean; + KeyNr : Integer; + LowKey : IsamKeyStr; + HighKey : IsamKeyStr; + StartScreenRow : Integer; + NrOfRows : Integer; + var DatS; + var DatLen : Word; + var Ref : LongInt; + var KeyStr : IsamKeyStr; + var ExitKey : BKtype; + ProcSpecialTask : Pointer; + ProcBuildaRow : Pointer; + ProcDisplayaRow : Pointer) : Integer; + {-A list is created with the corresponding keys from to + inclusive and their data structures. + + The parameter must be true for variable record lengths + (otherwise false). + + The display starts at the row and entails + rows. may not be less than 4. + + is a buffer for the data structure. + + contains the length of the current variable length record only + if is true. + + returns the code for the command that exited the Browser. In + addition this determines the first action the Browser should perform. + BKnone (Byte 0) must be passed if no action is to be performed. + + The procedures whose addresses are passed through the pointer-parameters + and are used to create and display a + row. These procedures must be supplied by the user of Browser and must + be declared as in the example procedure definition. These procedures + must be declared as "FAR." This is either done through the use of the + compiler directive $F+, or through the exportation from another Unit. + Handling it in any other way will produce a program crash. + + There are three possible return values: + 0: No error encountered. + = BKquit : Esc was pressed. + <> BKquit : contains the data structure, + the corresponding reference, + the chosen key. + 1: There were no keys available that were in the requested range. + 2: Hard Error by Isam-Access (Class 2 or higher). + + Browser has the following default actions for each command: + BKquit : exit Browser without making a selection + BKenter : exit Browser making a choice + BKfirstRec : scroll to the first data structure + BKlastRec : scroll to the last data structure + BKpageUp : scroll back a page + BKpageDown : scroll forward a page + BKup : scroll up a row + BKdown : scroll down a row + + If points to a procedure that makes use of the + parameter , horizontal scrolling is available through the + following commands: + BKleft : Move the display window towards the left + BKright : Move the display window towards the right.} + +function BrowseAgain(IFBPtr : IsamFileBlockPtr; + VarRec : Boolean; + KeyNr : Integer; + LowKey : IsamKeyStr; + HighKey : IsamKeyStr; + StartScreenRow, + NrOfRows : Integer; + var HighlightedRow : Integer; + var HorizOfs : Integer; + var DatS; + var DatLen : Word; + var Ref : LongInt; + var KeyStr : IsamKeyStr; + var ExitKey : BKtype; + ProcSpecialTask : Pointer; + ProcBuildaRow : Pointer; + ProcDisplayaRow : Pointer) : Integer; + {-Same as Browse, except takes a value for the row to position the highlight + bar on initially. If if 0, then the browser will position + the scroll bar for you. Otherwise must be between 1 and + . The value is also passed. This value is passed to + the user procedure to indicate the horizontal offset of + the line.} + +function AddBrowseCommand(Cmd : BKtype; NumKeys : Byte; Key1, Key2 : Word) : Boolean; + {-Add a new command key assignment or change an existing one} + +function BrowseReadKey : Word; + {-Return next keystroke as a word} + +procedure EnableFiltering(ValidateFunc : Pointer); + {-Enables Browser filtering. is a pointer to a user defined + function that determines whether a given record should be displayed in the + Browser. The must be a FAR, non-nested function declared as + follows: + + function ValidateARecord(IFBPtr : IsamFileBlockPtr; + KeyNr : Integer; + Ref : LongInt; + var KeyStr : IsamKeyStr; + NetUsed : Boolean) : Boolean; + } + +procedure DisableFiltering; + {-Disables Browser filtering. Has no effect if filtering is not enabled.} + +function IsFilteringEnabled : Boolean; + {-Returns True if Browser filtering is enabled.} + +{$IFDEF UseMouse} +procedure EnableBrowseMouse; + {-Enable mouse control of pick lists} + +procedure DisableBrowseMouse; + {-Disable mouse control of pick lists} +{$ENDIF} + +{!!.06 begin} +function RefreshAtEachCommand(IFBPtr : IsamFileBlockPtr; + KeyNo : Integer) : Boolean; + {-Check for need to refresh before each command if no keystrokes pending} + +const + RefreshPeriod : Word = 90; {about 5 seconds} + +function RefreshPeriodically(IFBPtr : IsamFileBlockPtr; + KeyNo : Integer) : Boolean; + {-Check for need to refresh every RefreshPeriod clock ticks} +{!!.06 end} + {=========================================================================} + +implementation + +{$IFDEF UseMouse} +const + MouseScale : Word = 10000; + PrevSlid : Byte = 0; {Previous scroll bar slider position} + SliderPos : Byte = 0; {position of the scroll bar slider} + SliderFunc : Pointer = nil; {Pointer to routine that gets mouse slider pos} + ScrollProc : Pointer = nil; {Pointer to routine that scrolls using slider pos} + MouseUpCmd : array[Boolean] of BKType = (BKUp, BKPageUp); + MouseDownCmd : array[Boolean] of BKType = (BKDown, BKPageDown); + ScrollBarPtr : string[1] = ' '; + ScrollBarTop : Byte = 2; {of the top of the bar} + ScrollBarBot : Byte = 18; {of the bottom of the bar} + ScrollBarDn : Byte = 19; {of the down arrow} + MouseLowScale : Word = 0; + MouseHighScale : Word = 0; +{$ENDIF} + +const + RepositionDesired : Boolean = False; + FilterState : Boolean = False; + + {------------- Browser filtering hooks ------------} +const + SearchKeyPtr : Pointer = Nil; + NextKeyPtr : Pointer = Nil; + PrevKeyPtr : Pointer = Nil; + FindKeyAndRefPtr : Pointer = Nil; + ValidatePtr : Pointer = Nil; + +type + RowRange = 1..MaxRows; + BrowScreenType = array[RowRange] of RowRec; + +var + CurRow : RowRange; + gHighKey : IsamKeyStr; {!!.22} + gLowKey : IsamKeyStr; {!!.22} + + procedure HelpRoutine(UnitCode : Byte; IdPtr : Pointer; HelpIndex : Word); + {-Call routine pointed to by BrowseHelpPtr} + inline( + $FF/$1E/>BrowseHelpPtr); {call dword ptr [>BrowseHelpPtr]} + + function GetKey : Word; + {-Call routine pointed to by BrowseKeyPtr} + inline( + $FF/$1E/>BrowseKeyPtr); {call dword ptr [>BrowseKeyPtr]} + + function KeyInBounds(KeyStr : IsamKeyStr) : Boolean; {!!.22 moved} + begin + KeyInBounds := False; + if Copy(KeyStr, 1, Length(gLowKey)) < gLowKey then {!!.22} + Exit; + if Copy(KeyStr, 1, Length(gHighKey)) > gHighKey then {!!.22} + Exit; + KeyInBounds := True; + end; + + function BrowseReadKey : Word; + {-Return next keystroke as a word} + var + Ch : Char; + begin + Ch := ReadKey; + if Ch <> #0 then + BrowseReadKey := Ord(Ch) + else + BrowseReadKey := Word(Ord(ReadKey)) shl 8; + end; + + {$IFDEF UseMouse} + procedure DrawMouseScrollBar; + {-Draw the mouse scroll bar} + var + S : String; + SLen : Byte absolute S; + + begin + if not UseScrollBar then + Exit; + SLen := ScrollBarHt + 2; + FillChar(S[2], SCrollBarHt, ScrollVertChar); + S[1] := MouseUpMark; {!!.40} + S[SLen] := MouseDnMark; {!!.40} + FastVert(S, ScrollBarUp, ScrollBarCol, ScrollBarAttr); + end; + {$ENDIF} + + function Validate(IFBPtr : IsamFileBlockPtr; + Key : Integer; + Ref : LongInt; + var KeyStr : IsamKeyStr; + NetUsed : Boolean) : Boolean; + inline($FF/$1E/>ValidatePtr); {call dword ptr [>ValidatePtr]} + + {$F+} + procedure Next_Key(IFBPtr : IsamFileBlockPtr; + Key : Integer; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr; + NetUsed : Boolean); + var + RT : Integer; + begin + RT := 0; + repeat + BTNextKey(IFBPtr, Key, UserDatRef, UserKey); + Inc(RT); + until (RT >= RetriesOnLock) or (BTIsamErrorClass <> 2); + end; + + procedure Search_Key(IFBPtr : IsamFileBlockPtr; + Key : Integer; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr; + NetUsed : Boolean); + var + RT : Integer; + begin + RT := 0; + repeat + BTSearchKey(IFBPtr, Key, UserDatRef, UserKey); + Inc(RT); + until (RT >= RetriesOnLock) or (BTIsamErrorClass <> 2); + end; + + procedure Prev_Key(IFBPtr : IsamFileBlockPtr; + Key : Integer; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr; + NetUsed : Boolean); + var + RT : Integer; + begin + RT := 0; + repeat + BTPrevKey(IFBPtr, Key, UserDatRef, UserKey); + Inc(RT); + until (RT >= RetriesOnLock) or (BTIsamErrorClass <> 2); + end; + + procedure Find_Key(IFBPtr : IsamFileBlockPtr; + Key : Integer; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr; + NFSD : Integer; + NetUsed : Boolean); + var + RT : Integer; + + begin + RT := 0; + repeat + BTFindKeyAndRef(IFBPtr, Key, UserDatRef, UserKey, NFSD); + Inc(RT); + until (RT >= RetriesOnLock) or (BTIsamErrorClass <> 2); + end; + + procedure FilterNextKey(IFBPtr : IsamFileBlockPtr; + Key : Integer; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr; + NetUsed : Boolean); + var + Done : Boolean; + begin + Next_Key(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + Done := False; {!!.22 begin} + while IsamOK and (not Done) and KeyInBounds(UserKey) do begin + Done := Validate(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + if (not Done) and IsamOK then + Next_Key(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + end; {!!.22 end} + end; + + procedure FilterSearchKey(IFBPtr : IsamFileBlockPtr; + Key : Integer; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr; + NetUsed : Boolean); + var + Done : Boolean; + begin + Search_Key(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + Done := False; {!!.22 begin} + while IsamOK and (not Done) and KeyInBounds(UserKey) do begin + Done := Validate(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + if (not Done) and (IsamOK) then + Next_Key(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + end; {!!.22 end} + if BTIsamErrorClass = 1 then + IsamError := 10210; + end; + + procedure FilterPrevKey(IFBPtr : IsamFileBlockPtr; + Key : Integer; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr; + NetUsed : Boolean); + var + Done : Boolean; + begin + Prev_Key(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + Done := False; {!!.07} + while IsamOK and (not Done) and KeyInBounds(UserKey) do begin + Done := Validate(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + if (not Done) and IsamOK then + Prev_Key(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + end; {!!.07} + end; + + procedure FilterFindKey(IFBPtr : IsamFileBlockPtr; + Key : Integer; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr; + NFSD : Integer; + NetUsed : Boolean); + var + Done : Boolean; + begin + Find_Key(IFBPtr, Key, UserDatRef, UserKey, NFSD, NetUsed); + Done := False; {!!.22 begin} + while IsamOK and (not Done) and KeyInBounds(UserKey) do begin + Done := Validate(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + if (not Done) and (IsamOK) then + case NFSD of + 0 : begin {no direction} + IsamOK := False; + IsamError := 10270; + end; + 1 : Next_Key(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + else + Prev_Key(IFBPtr, Key, UserDatRef, UserKey, NetUsed); + end; + end; {!!.22 end} + end; + + {$F-} + + {$I browser.inc} {include the BrowseI function} + + function GetCursorMode : Word; + const + Video = $10; + GetCurType = $300; + var + Regs : Registers; + begin + Regs.AX := GetCurType; + Intr(Video, Regs); + GetCursorMode := Regs.CX; + end; + + procedure SetCursorMode(Mode : Word); + const + Video = $10; + SetCurType = $100; + var + Regs : Registers; + begin + Regs.AX := SetCurType; + Regs.CX := Mode; + Intr(Video, Regs); + end; + + {$IFDEF UseMouse} + procedure InitMouseScrollBar(StartScreenRow, NrOfRows : Integer); + + begin + if not UseScrollBar then + Exit; + if ScrollBarAutoSize then begin + ScrollBarHt := NrOfRows; + if StartScreenRow > 1 then + ScrollBarUp := Pred(StartScreenRow) + else + ScrollBarUp := StartScreenRow; + end; + ScrollBarTop := Succ(ScrollBarUp); + ScrollBarBot := ScrollBarTop + Pred(ScrollBarHt); + if StartScreenRow = 1 then + Dec(ScrollBarBot); + ScrollBarDn := Succ(ScrollBarBot); + SliderPos := ScrollBarTop; + end; + {$ENDIF} + + function Browse(IFBPtr : IsamFileBlockPtr; + VarRec : Boolean; + KeyNr : Integer; + LowKey : IsamKeyStr; + HighKey : IsamKeyStr; + StartScreenRow, + NrOfRows : Integer; + var DatS; + var DatLen : Word; + var Ref : LongInt; + var KeyStr : IsamKeyStr; + var ExitKey : BKtype; + ProcSpecialTask : Pointer; + ProcBuildaRow : Pointer; + ProcDisplayaRow : Pointer) : Integer; + var + SaveTextAttr : Byte; + SaveCursor : Word; + SaveSFS : Boolean; + SaveError : Integer; + Desired, HorizOfs : Integer; + + {$IFDEF UseMouse} + var + SaveMouseOn : Boolean; + SaveWaitForButton : Boolean; + {$ENDIF} + + begin + SaveTextAttr := TextAttr; + SaveCursor := GetCursorMode; + BrowseYL := StartScreenRow; + BrowseYH := BrowseYL + Pred(NrOfRows); + {$IFDEF UseMouse} + if BrowseMouseEnabled then begin + InitMouseScrollBar(StartScreenRow, NrOfRows); + SaveMouseOn := MouseCursorOn; + if SaveMouseOn then + HideMouse; + DrawMouseScrollBar; + SaveWaitForButton := WaitForButtonRelease; + WaitForButtonRelease := True; + end; + {$ENDIF} + {Hide the cursor} + SetCursorMode($2000); + BTGetSearchForSequential(IFBPtr, KeyNr, SaveSFS); + BTSetSearchForSequential(IFBPtr, KeyNr, True); + Desired := 1; + HorizOfs := 0; + Browse := BrowseI(IFBPtr, VarRec, KeyNr, LowKey, HighKey, StartScreenRow, + NrOfRows, Desired, HorizOfs, DatS, DatLen, Ref, KeyStr, + ExitKey, ProcSpecialTask, ProcBuildaRow, + ProcDisplayaRow); + SaveError := IsamError; + BTSetSearchForSequential(IFBPtr, KeyNr, SaveSFS); + IsamError := SaveError; + IsamOK := (IsamError = 0); + SetCursorMode(SaveCursor); + TextAttr := SaveTextAttr; + {$IFDEF UseMouse} + if BrowseMouseEnabled then begin + WaitForButtonRelease := SaveWaitForButton; + if SaveMouseOn then begin + if not MouseCursorOn then + ShowMouse; + end + else if MouseCursorOn then + HideMouse; + end; + {$ENDIF} + end; + + function BrowseAgain(IFBPtr : IsamFileBlockPtr; + VarRec : Boolean; + KeyNr : Integer; + LowKey : IsamKeyStr; + HighKey : IsamKeyStr; + StartScreenRow, + NrOfRows : Integer; + var HighlightedRow : Integer; + var HorizOfs : Integer; + var DatS; + var DatLen : Word; + var Ref : LongInt; + var KeyStr : IsamKeyStr; + var ExitKey : BKtype; + ProcSpecialTask : Pointer; + ProcBuildaRow : Pointer; + ProcDisplayaRow : Pointer) : Integer; + var + SaveTextAttr : Byte; + SaveCursor : Word; + SaveSFS : Boolean; + SaveError : Integer; + + {$IFDEF UseMouse} + var + SaveMouseOn : Boolean; + SaveWaitForButton : Boolean; + {$ENDIF} + + begin + SaveTextAttr := TextAttr; + SaveCursor := GetCursorMode; + BrowseYL := StartScreenRow; + BrowseYH := BrowseYL + Pred(NrOfRows); + {$IFDEF UseMouse} + if BrowseMouseEnabled then begin + InitMouseScrollBar(StartScreenRow, NrOfRows); + SaveMouseOn := MouseCursorOn; + if SaveMouseOn then + HideMouse; + DrawMouseScrollBar; + SaveWaitForButton := WaitForButtonRelease; + WaitForButtonRelease := True; + end; + {$ENDIF} + {Hide the cursor} + SetCursorMode($2000); + BTGetSearchForSequential(IFBPtr, KeyNr, SaveSFS); + BTSetSearchForSequential(IFBPtr, KeyNr, True); + BrowseAgain := BrowseI(IFBPtr, VarRec, KeyNr, LowKey, HighKey, + StartScreenRow, NrOfRows, HighlightedRow, + HorizOfs, DatS, DatLen, Ref, KeyStr, + ExitKey, ProcSpecialTask, ProcBuildaRow, + ProcDisplayaRow); + SaveError := IsamError; + BTSetSearchForSequential(IFBPtr, KeyNr, SaveSFS); + IsamError := SaveError; + IsamOK := (IsamError = 0); + SetCursorMode(SaveCursor); + TextAttr := SaveTextAttr; + {$IFDEF UseMouse} + if BrowseMouseEnabled then begin + WaitForButtonRelease := SaveWaitForButton; + if SaveMouseOn then begin + if not MouseCursorOn then + ShowMouse; + end + else if MouseCursorOn then + HideMouse; + end; + {$ENDIF} + end; + procedure EnableFiltering(ValidateFunc : Pointer); + {-Enables Browser filtering. is a pointer to a user defined + function that determines whether a given record should be displayed in the + Browser. The must be a FAR, non-nested function declared as + follows: + + function ValidateARecord(IFBPtr : IsamFileBlockPtr; + KeyNr : Integer; + Ref : LongInt; + var KeyStr : IsamKeyStr) : Boolean; + } + begin + FilterState := True; + SearchKeyPtr := @FilterSearchKey; + NextKeyPtr := @FilterNextKey; + PrevKeyPtr := @FilterPrevKey; + FindKeyAndRefPtr := @FilterFindKey; + ValidatePtr := ValidateFunc; + end; + + procedure DisableFiltering; + {-Disables Browser filtering.} + begin + FilterState := False; + SearchKeyPtr := @Search_Key; + NextKeyPtr := @Next_Key; + PrevKeyPtr := @Prev_Key; + FindKeyAndRefPtr := @Find_Key; + end; + + function IsFilteringEnabled : Boolean; + {-Returns True if Browser filtering is enabled.} + begin + IsFilteringEnabled := FilterState; + end; + + function AddBrowseCommand(Cmd : BKtype; NumKeys : Byte; Key1, Key2 : Word) : Boolean; + {-Add a new command key assignment or change an existing one} + begin + AddBrowseCommand := + AddCommandPrim(BrowseKeySet, BrowseKeyMax, Cmd, NumKeys, Key1, Key2); + end; + + {$IFDEF UseMouse} + procedure EnableBrowseMouse; + {-Enable mouse control of Browser} + begin + if MouseInstalled then begin + {$IFDEF UseTPCRT} + BrowseKeyPtr := @TPMouse.ReadKeyOrButton; + {$ELSE} + BrowseKeyPtr := @OPMouse.ReadKeyOrButton; + {$ENDIF} + EnableEventHandling; + BrowseMouseEnabled := True; + end; + end; + + procedure DisableBrowseMouse; + {-Disable mouse control of Browser} + begin + if BrowseMouseEnabled then begin + BrowseKeyPtr := @ReadKeyWord; + DisableEventHandling; + BrowseMouseEnabled := False; + end; + end; + {$ENDIF} + +begin + {initialize procedure pointers} + BrowseHelpPtr := nil; + DisableFiltering; + {$IFDEF UseTPCRT} + BrowseKeyPtr := @TpCrt.ReadKeyWord; + {$ELSE} + {$IFDEF UseOPCRT} + BrowseKeyPtr := @OpCrt.ReadKeyWord; + {$ELSE} + BrowseKeyPtr := @BrowseReadKey; + {$ENDIF} + {$ENDIF} +end. diff --git a/src/wc_sdk/btbase.pas b/src/wc_sdk/btbase.pas new file mode 100644 index 0000000..06af01b --- /dev/null +++ b/src/wc_sdk/btbase.pas @@ -0,0 +1,85 @@ +{********************************************************************} +{* BTBase.PAS - B-Tree Filer basic types & constants *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{$I btdefine.inc} + +unit BTBase; + +{Notes: This unit is designed so that all compilers have the same + types and constants as each other. This in turn makes the + code easier} + +interface + +{$IFDEF Win32} {!!.54} +uses {!!.54} + Windows; {!!.54} +{$ENDIF} {!!.54} + +type + {$IFDEF VER70} + SmallInt = integer; + Cardinal = word; + {$ENDIF} + + {$IFDEF FPC} + DWORD = LongWord; + TbtfErrorCode = LongInt; + TbtfHandle = LongInt; + TbtfMemSize = LongInt; + PAnsiChar = PChar; + {$ELSE} + {$IFDEF Win32} + TbtfErrorCode = integer; + TbtfHandle = DWORD; + TbtfMemSize = DWORD; + {$ELSE} + DWORD = longint; {!!.54} + TbtfErrorCode = word; + TbtfHandle = word; + TbtfMemSize = word; + PAnsiChar = PChar; + {$ENDIF} + {$ENDIF} + +{$IFDEF FPC} +const + INVALID_HANDLE_VALUE = TbtfHandle(-1); +{$ELSE} +{$IFNDEF Win32} +const + INVALID_HANDLE_VALUE = $FFFF; +{$ENDIF} +{$ENDIF} + +implementation + +end. diff --git a/src/wc_sdk/btdefine.inc b/src/wc_sdk/btdefine.inc new file mode 100644 index 0000000..6426b1f --- /dev/null +++ b/src/wc_sdk/btdefine.inc @@ -0,0 +1,491 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * Rob Roberts robr@pcisys.net + * + * ***** END LICENSE BLOCK ***** *) + +{---Conditional defines that affect B-Tree Filer units---} + +{===FPC compiler detection===========================================} +{$IFDEF FPC} + {$DEFINE UsingFPC} + {$DEFINE Heap6} + {$Mode TP} + {$PackRecords 1} + {$PackEnum 1} + {$H-} + {$GOTO ON} + {$POINTERMATH ON} + {-FPC defines WINDOWS and WIN32 for Windows targets. + B-Tree Filer uses these for 16-bit BP and Delphi code paths + (WinTypes/WinProcs, initialization/finalization, excludes + BaseSupp). None of these apply to FPC in TP mode. Undefine + both so FPC/Windows uses the same safe code paths as go32v2. + MSWINDOWS remains defined for Windows API calls.} + {$IFDEF WINDOWS} + {$UNDEF WINDOWS} + {$ENDIF} + {$IFDEF WIN32} + {$UNDEF WIN32} + {$ENDIF} + {$IFDEF WIN64} + {$UNDEF WIN64} + {$ENDIF} +{$ENDIF} + +{===B-Tree Filer defines=============================================} +{.$DEFINE NoNet} +{.$DEFINE Novell} +{$DEFINE MsNet} +{-Valid network interfaces. One or more must be defined, but NoNet + may not be selected except by itself. Novell is not valid for + 32-bit Delphi. For a real network, our recommendation is to always + use MsNet.} + +{$IFDEF Novell} +{.$DEFINE SupportVLM} +{-If compiling for Novell NetWare, defining SupportVLM will link in + the relevant NWXXXX units to support VLMs as well as NETX. This is + not an option for the DLL.} +{$ENDIF} + +{$IFNDEF DPMI} +{$IFNDEF Windows} +{$IFNDEF Win32} +{$IFNDEF FPC} +{$DEFINE UseEMSHeap} +{-Adds code to the FILER unit to store page buffers in EMS in real + mode only. EMS cannot be used under Windows, DPMI, or FPC.} +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{$IFDEF UseEMSHeap} +{.$DEFINE EMSDisturbance} +{-Adds code to save and restore the EMS page mapping.} +{$ENDIF} + +{.$DEFINE InitAllUnits} +{-Activate this define to cause all B-Tree Filer units to have an + initialization block, even if only an empty one. This works around + a bug in some very early versions of Borland's Turbo Debugger.} + +{$IFDEF Win32} +{$DEFINE SuppressWarnings} +{$ENDIF} +{-Activate this define to force Delphi 2.0 and 3.0 to display all + Hints and Warnings} + +{-Note: the defines for DebugEMSHeap, NoErrorCheckEMSHeap, + ManualInitEMSHeap, UseTPEMS, and UseOPEMS have been moved into + EMSHEAP.PAS, which is the only unit they affect.} + +{====================================================================} + + +{===Common defines between static/dynamic linked B-Tree Filer========} + +{$IFNDEF NoNet} +{.$DEFINE LockBeforeRead} +{-Automatically locks any file section before reading it, then + unlocks. May be needed to avoid a bug in some versions of the + NetWare NETX shell.} +{$ENDIF} + +{$DEFINE LengthByteKeys} +{.$DEFINE AsciiZeroKeys} +{-One of LengthByteKeys or AsciiZeroKeys must be defined, but not + both. LengthByteKeys causes B-Tree Filer to store Turbo Pascal style + strings in the index file. AsciiZeroKeys causes B-Tree Filer to + store C-style ASCIIZ strings in the index file.} + +{.$DEFINE UseTPCRT} +{.$DEFINE UseOPCRT} +{-Either UseTPCRT or UseOPCRT may be defined, but not both. These + defines affect the BROWSER unit only (and programs using BROWSER, + for example NETDEMO). Don't activate either one if the program uses + neither the TPCRT nor OPCRT units from Turbo Professional and + Object Professional, respectively.} + +{====================================================================} + +(********************************************************************) +(********************************************************************) +{Don't change anything beyond this point} + +{The following define allows extensions to B-Tree Filer to detect the + new syntax of versions 5.2 and later.} + +{$DEFINE BTree52} + +{The following define allows extensions to B-Tree Filer to detect the + new syntax of versions 5.4 and later.} + +{$DEFINE BTree54} + +{--Define whether a DPMI or Windows compiler is used} + {$IFDEF Windows} + {$DEFINE DPMIOrWnd} + {$ENDIF} + {$IFDEF DPMI} + {$DEFINE DPMIOrWnd} + {$ENDIF} + {$IFDEF Win32} + {$DEFINE DPMIOrWnd} + {$ENDIF} + +{--Define the syntax of BTInitIsam to be used} + {$IFDEF Windows} + {$DEFINE UseWindowsInit} + {$ENDIF} + {$IFDEF Win32} + {$DEFINE UseWindowsInit} + {$ENDIF} + +{--Check for .NET} {!!.57} + {$IFDEF CLR} {!!.57} + !! B-Tree Filer does not support .NET {!!.57} + {$ENDIF} {!!.57} + +{--Define whether using Delphi} + {$IFDEF VER80} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER90} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER100} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER120} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER130} + {$DEFINE UsingDelphi} + {$ENDIF} + {$IFDEF VER140} {!!.56} + {$DEFINE UsingDelphi} {!!.56} + {$ENDIF} {!!.56} + {$IFDEF VER150} {!!.56} + {$DEFINE UsingDelphi} {!!.56} + {$ENDIF} {!!.56} + {$IFDEF VER170} {!!.57} + {$DEFINE UsingDelphi} {!!.57} + {$ENDIF} {!!.57} + {$IFDEF VER180} {!!.57a} + {$DEFINE UsingDelphi} {!!.57a} + {$ENDIF} {!!.57a} + +{--Define whether overlays can be allowed} + {$IFDEF FPC} + {$UNDEF CanAllowOverlays} + {$ELSE} + {$IFDEF MSDOS} + {$DEFINE CanAllowOverlays} + {$ELSE} + {$UNDEF CanAllowOverlays} + {$ENDIF} + {$ENDIF} + +{--Test the definition of the net interfaces} + {$IFDEF Novell} + {$DEFINE RealNetDefined} + {$ENDIF} + {$IFDEF MsNet} + {$DEFINE RealNetDefined} + {$ENDIF} + + {$IFDEF NoNet} + {$IFDEF RealNetDefined} + !! ERROR: You may not define NoNet and any other Net simultaneously + {$ENDIF} + {$ELSE} + {$IFNDEF RealNetDefined} + !! ERROR: You must define either NoNet or at least one real network + {$ENDIF} + {$ENDIF} + {$UNDEF RealNetDefined} + +{--Test the XXKeys defines} + {$IFDEF LengthByteKeys} + {$IFDEF ASCIIZeroKeys} + !! ERROR: You may not define both LengthByteKeys and AsciiZeroKeys + {$ENDIF} + {$ELSE} + {$IFNDEF ASCIIZeroKeys} + !! ERROR: You must define either LengthByteKeys or AsciiZeroKeys + {$ENDIF} + {$ENDIF} + +{--Test the UseXXCrt defines} + {$IFDEF UseTPCRT} + {$IFDEF UseOPCRT} + !! ERROR: You may not define both UseTPCrt and UseOPCrt + {$ENDIF} + {$ENDIF} + +{--Test the FILER.MAK directives} + {$IFDEF TProOnly} + {$IFNDEF UseTPCrt} + !! ERROR: You must define UseTPCRT if compiling with TPro + {$ENDIF} + {$ENDIF} + {$IFDEF OProOnly} + {$IFNDEF UseOPCrt} + !! ERROR: You must define UseOPCRT if compiling with OPro + {$ENDIF} + {$ENDIF} + +{--Test for Win32 exclusions} + + {$IFDEF Win32} + {$IFDEF Novell} + !! ERROR: Novell network type is not available for 32-bit Delphi + {$ENDIF} + {$IFDEF UseTPCRT} + {$UNDEF UseTPCrt} + {$ENDIF} + {$IFDEF UseOPCRT} + {$UNDEF UseOPCrt} + {$ENDIF} + {$ENDIF} + +{--Win32 hints/warnings} + + {$IFDEF Win32} + {$IFDEF SuppressWarnings} + {$WARNINGS OFF} + {$HINTS OFF} + {$ELSE} + {$WARNINGS ON} + {$HINTS ON} + {$ENDIF} + {$ENDIF} + +{===Compiler options (not to be changed)=============================} +{$IFDEF FPC} +{$B-} {short circuit boolean evaluation} +{$I-} {suppress I/O checking} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$ENDIF} + +{$IFDEF VER70} {Borland Pascal 7.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$I-} {suppress I/O checking} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$S-} {stack checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$ENDIF} + +{$IFDEF VER80} {Delphi 1.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$G+} {generate 80286 code} +{$I-} {suppress I/O checking} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$S-} {stack checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi1} +{$DEFINE Delphi1Plus} +{$ENDIF} + +{$IFDEF VER90} {Delphi 2.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi2} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$ENDIF} + +{$IFDEF VER100} {Delphi 3.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi3} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$ENDIF} + +{$IFDEF VER120} {Delphi 4.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi4} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$ENDIF} + +{$IFDEF VER130} {Delphi 5.0} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi5} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$ENDIF} + +{$IFDEF VER140} {Delphi 6.0} {new !!.56} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi6} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$DEFINE Delphi6Plus} +{$ENDIF} + +{$IFDEF VER150} {Delphi 7.0} {new !!.56} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi7} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$DEFINE Delphi6Plus} +{$DEFINE Delphi7Plus} +{$ENDIF} + +{$IFDEF VER170} {Delphi 2005} {!!.57} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi2005} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$DEFINE Delphi6Plus} +{$DEFINE Delphi7Plus} +{$DEFINE Delphi2005Plus} +{$ENDIF} + +{$IFDEF VER180} {Delphi 2006} {!!.57a} +{$A-} {align data on byte boundaries} +{$B-} {short circuit boolean evaluation} +{$H+} {long string support} +{$I-} {suppress I/O checking} +{$J+} {writeable typed constants} +{$P-} {do not allow open string parameters} +{$Q-} {overflow checking off} +{$R-} {range checking off} +{$T-} {no type checked pointers with @} +{$V-} {no var string checking} +{$X+} {extended syntax on} +{$DEFINE Delphi2006} +{$DEFINE Delphi1Plus} +{$DEFINE Delphi2Plus} +{$DEFINE Delphi3Plus} +{$DEFINE Delphi4Plus} +{$DEFINE Delphi5Plus} +{$DEFINE Delphi6Plus} +{$DEFINE Delphi7Plus} +{$DEFINE Delphi2005Plus} +{$DEFINE Delphi2006Plus} +{$ENDIF} + diff --git a/src/wc_sdk/btfileio.pas b/src/wc_sdk/btfileio.pas new file mode 100644 index 0000000..5548b1c --- /dev/null +++ b/src/wc_sdk/btfileio.pas @@ -0,0 +1,1296 @@ +{********************************************************************} +{* BTFileIO.PAS - B-Tree Filer low-level file I/O routines *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{$I btdefine.inc} + +unit BTFileIO; + +interface + +uses + {$IFDEF Win32} {!!.54} + Windows, {!!.54} + {$ENDIF} {!!.54} + BTBase; + +var + btfDOSFunc : word; + btfDOSError : TbtfErrorCode; + +type + TbtfOpenMode = (bomReadOnly, bomReadWrite); + TbtfShareMode = (bsmExclusive, bsmShared); + +function btfCloseFile(aHandle : TbtfHandle) : boolean; + {-close the file} +function btfDeleteFile(aName : PAnsiChar) : boolean; + {-delete the file} +function btfFlushFile(aHandle : TbtfHandle) : boolean; + {-flush the file} +function btfGetPositionFile(aHandle : TbtfHandle; + var aOffset : DWORD) : boolean; {!!.54} + {-return the current file position} +function btfLockFile(aHandle : TbtfHandle; + aStart : longint; + aCount : longint) : boolean; + {-lock the file} +function btfOpenFile(aName : PAnsiChar; + aOpenMode : TbtfOpenMode; + aShareMode : TbtfShareMode; + aWriteThru : boolean; + aCreateFile : boolean; + aInheritable: boolean; + var aHandle : TbtfHandle) : boolean; + {-open the file, return the handle} +function btfPositionFile(aHandle : TbtfHandle; + aOffset : longint) : boolean; + {-set the file position} +function btfPositionFileEOF(aHandle : TbtfHandle; + var aFileSize : DWORD) : boolean; {!!.54} + {-set the file position at EOF, return the filesize} +function btfReadFile(aHandle : TbtfHandle; + aToRead : longint; + var aBuffer; + var aBytesRead : longint) : boolean; + {-read from the file, return the number of bytes read} +function btfRenameFile(aName : PAnsiChar; + aNewName : PAnsiChar) : boolean; + {-rename the file} +function btfSetEOF(aHandle : TbtfHandle; + aOffset : longint) : boolean; + {-truncate the file} +function btfUnlockFile(aHandle : TbtfHandle; + aStart : longint; + aCount : longint) : boolean; + {-unlock the file} +function btfWriteFile(aHandle : TbtfHandle; + aToWrite : longint; + const aBuffer; + var aBytesWritten : longint) : boolean; + {-write to the file, return the number of bytes written} + +implementation + +{$IFDEF FPC} +uses + SysUtils + {$IFDEF GO32V2} + , go32 + {$ENDIF} + {$IFDEF UNIX} + , BaseUnix, Unix + {$ENDIF} + {$IFDEF MSWINDOWS} + , Windows + {$ENDIF} + ; + +{$IFDEF UNIX} +const + cF_RDLCK = 0; + cF_WRLCK = 1; + cF_UNLCK = 2; +{$ENDIF} +{$ELSE} +{$IFDEF Windows} +uses + WinTypes, WinProcs; +{$ENDIF} +{$IFNDEF FPC} +{$IFDEF DPMI} +uses + WinAPI; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{===Common routines==================================================} +function MaxLong(a, b : longint) : longint; +begin + if (a > b) then + MaxLong := a + else + MaxLong := b; +end; +{--------} +function MinLong(a, b : longint) : longint; +begin + if (a < b) then + MinLong := a + else + MinLong := b; +end; +{====================================================================} + + +{===FPC go32v2 calls=================================================} +{$IFDEF FPC} +function SetErrorCode(aDosFunc : word) : boolean; +begin + SetErrorCode := false; + btfDOSFunc := aDosFunc; + btfDOSError := 1; { generic error } +end; +{--------} +function btfCloseFile(aHandle : TbtfHandle) : boolean; +begin + if aHandle < 0 then begin + btfCloseFile := SetErrorCode($3E00); + Exit; + end; + FileClose(aHandle); + btfCloseFile := true; +end; +{--------} +function btfDeleteFile(aName : PAnsiChar) : boolean; +var + S : string; +begin + S := StrPas(aName); + if not SysUtils.DeleteFile(S) then + btfDeleteFile := SetErrorCode($4100) + else + btfDeleteFile := true; +end; +{--------} +function btfFlushFile(aHandle : TbtfHandle) : boolean; +{$IFDEF GO32V2} +var + Regs : TRealRegs; +begin + { Use DOS INT 21h/$68 (commit file) via real-mode interrupt } + FillChar(Regs, SizeOf(Regs), 0); + Regs.AX := $6800; + Regs.BX := Word(aHandle); + RealIntr($21, Regs); + if (Regs.Flags and 1) <> 0 then + btfFlushFile := SetErrorCode($6800) + else + btfFlushFile := true; +end; +{$ELSE} +begin + {$IFDEF UNIX} + if fpfsync(aHandle) <> 0 then + btfFlushFile := SetErrorCode($6800) + else + {$ENDIF} + {$IFDEF MSWINDOWS} + if not FlushFileBuffers(aHandle) then + btfFlushFile := SetErrorCode($6800) + else + {$ENDIF} + btfFlushFile := true; +end; +{$ENDIF} +{--------} +function btfGetPositionFile(aHandle : TbtfHandle; + var aOffset : DWORD) : boolean; +var + Pos : LongInt; +begin + Pos := FileSeek(aHandle, 0, fsFromCurrent); + if Pos = -1 then begin + btfGetPositionFile := SetErrorCode($4201); + end + else begin + aOffset := Pos; + btfGetPositionFile := true; + end; +end; +{--------} +function btfLockFile(aHandle : TbtfHandle; + aStart : longint; + aCount : longint) : boolean; +{$IFDEF GO32V2} +var + Regs : TRealRegs; +begin + { DOS INT 21h/$5C00 = lock region } + FillChar(Regs, SizeOf(Regs), 0); + Regs.AX := $5C00; + Regs.BX := Word(aHandle); + Regs.CX := Word(aStart shr 16); + Regs.DX := Word(aStart); + Regs.SI := Word(aCount shr 16); + Regs.DI := Word(aCount); + RealIntr($21, Regs); + if (Regs.Flags and 1) <> 0 then begin + btfDOSFunc := $5C00; + btfDOSError := Regs.AX; + btfLockFile := false; + end + else + btfLockFile := true; +end; +{$ELSE} +{$IFDEF UNIX} +var + fl : BaseUnix.flock; +begin + FillChar(fl, SizeOf(fl), 0); + fl.l_type := cF_WRLCK; + fl.l_whence := SEEK_SET; + fl.l_start := aStart; + fl.l_len := aCount; + if fpfcntl(aHandle, F_SETLK, fl) <> 0 then begin + btfDOSFunc := $5C00; + btfDOSError := fpgeterrno; + btfLockFile := false; + end + else + btfLockFile := true; +end; +{$ELSE} +begin + { Windows or other: assume success for now } + btfLockFile := true; +end; +{$ENDIF} +{$ENDIF} +{--------} +function btfOpenFile(aName : PAnsiChar; + aOpenMode : TbtfOpenMode; + aShareMode : TbtfShareMode; + aWriteThru : boolean; + aCreateFile : boolean; + aInheritable: boolean; + var aHandle : TbtfHandle) : boolean; +var + Mode : LongInt; + H : THandle; + S : string; +begin + aHandle := INVALID_HANDLE_VALUE; + S := StrPas(aName); + if aCreateFile then begin + H := FileCreate(S); + if H < 0 then begin + btfOpenFile := SetErrorCode($3C00); + Exit; + end; + aHandle := H; + btfOpenFile := true; + end + else begin + if aOpenMode = bomReadOnly then + Mode := fmOpenRead + else + Mode := fmOpenReadWrite; + if aShareMode = bsmExclusive then + Mode := Mode or fmShareExclusive + else + Mode := Mode or fmShareDenyNone; + H := FileOpen(S, Mode); + if H < 0 then begin + btfDOSFunc := $3D00; + btfDOSError := 2; { file not found } + btfOpenFile := false; + Exit; + end; + aHandle := H; + btfOpenFile := true; + end; +end; +{--------} +function btfPositionFile(aHandle : TbtfHandle; + aOffset : longint) : boolean; +var + Pos : LongInt; +begin + Pos := FileSeek(aHandle, aOffset, fsFromBeginning); + if Pos = -1 then + btfPositionFile := SetErrorCode($4200) + else + btfPositionFile := true; +end; +{--------} +function btfPositionFileEOF(aHandle : TbtfHandle; + var aFileSize : DWORD) : boolean; +var + Pos : LongInt; +begin + Pos := FileSeek(aHandle, 0, fsFromEnd); + if Pos = -1 then begin + btfPositionFileEOF := SetErrorCode($4202); + end + else begin + aFileSize := Pos; + btfPositionFileEOF := true; + end; +end; +{--------} +function btfReadFile(aHandle : TbtfHandle; + aToRead : longint; + var aBuffer; + var aBytesRead : longint) : boolean; +var + BR : LongInt; +begin + BR := FileRead(aHandle, aBuffer, aToRead); + if BR < 0 then begin + btfReadFile := SetErrorCode($3F00); + aBytesRead := 0; + end + else begin + aBytesRead := BR; + btfReadFile := true; + end; +end; +{--------} +function btfRenameFile(aName : PAnsiChar; + aNewName : PAnsiChar) : boolean; +var + SOld, SNew : string; +begin + SOld := StrPas(aName); + SNew := StrPas(aNewName); + if not SysUtils.RenameFile(SOld, SNew) then + btfRenameFile := SetErrorCode($5600) + else + btfRenameFile := true; +end; +{--------} +function btfSetEOF(aHandle : TbtfHandle; + aOffset : longint) : boolean; +begin + if not btfPositionFile(aHandle, aOffset) then begin + btfSetEOF := false; + Exit; + end; + if not FileTruncate(aHandle, aOffset) then + btfSetEOF := SetErrorCode($4000) + else + btfSetEOF := true; +end; +{--------} +function btfUnlockFile(aHandle : TbtfHandle; + aStart : longint; + aCount : longint) : boolean; +{$IFDEF GO32V2} +var + Regs : TRealRegs; +begin + { DOS INT 21h/$5C01 = unlock region } + FillChar(Regs, SizeOf(Regs), 0); + Regs.AX := $5C01; + Regs.BX := Word(aHandle); + Regs.CX := Word(aStart shr 16); + Regs.DX := Word(aStart); + Regs.SI := Word(aCount shr 16); + Regs.DI := Word(aCount); + RealIntr($21, Regs); + if (Regs.Flags and 1) <> 0 then begin + btfDOSFunc := $5C01; + btfDOSError := Regs.AX; + btfUnlockFile := false; + end + else + btfUnlockFile := true; +end; +{$ELSE} +{$IFDEF UNIX} +var + fl : BaseUnix.flock; +begin + FillChar(fl, SizeOf(fl), 0); + fl.l_type := cF_UNLCK; + fl.l_whence := SEEK_SET; + fl.l_start := aStart; + fl.l_len := aCount; + if fpfcntl(aHandle, F_SETLK, fl) <> 0 then begin + btfDOSFunc := $5C01; + btfDOSError := fpgeterrno; + btfUnlockFile := false; + end + else + btfUnlockFile := true; +end; +{$ELSE} +begin + btfUnlockFile := true; +end; +{$ENDIF} +{$ENDIF} +{--------} +function btfWriteFile(aHandle : TbtfHandle; + aToWrite : longint; + const aBuffer; + var aBytesWritten : longint) : boolean; +var + BW : LongInt; +begin + BW := FileWrite(aHandle, aBuffer, aToWrite); + if BW < 0 then begin + btfWriteFile := SetErrorCode($4000); + aBytesWritten := 0; + end + else begin + aBytesWritten := BW; + btfWriteFile := true; + end; +end; +{$ELSE} +{===Win16 and DOS calls==============================================} +{$IFNDEF Win32} +const + {constants for opening a file, etc} + OPEN_ACCESS_READONLY = 0; + OPEN_ACCESS_READWRITE = 2; + OPEN_SHARE_DENYREADWRITE = $10; + OPEN_SHARE_DENYWRITE = $20; + OPEN_SHARE_DENYNONE = $40; + OPEN_FLAGS_NOINHERIT = $80; + OPEN_FLAGS_NOCRITERR = $2000; + OPEN_FLAGS_COMMIT = $4000; + FILE_CREATE = $10; + FILE_OPEN = $01; + FILE_TRUNCATE = $02; + FILE_CREATE_ALWAYS = FILE_CREATE + FILE_TRUNCATE; + +{---Base file I/O routines-------------------------------------------} +function CheckForSuccess(aDosFunc : word; + aDosError : TbtfErrorCode) : boolean; +begin + if (aDosError <> 0) then begin + btfDOSFunc := aDosFunc; + btfDOSError := aDosError; + CheckForSuccess := false; + end + else + CheckForSuccess := true; +end; +{--------} +function baseReadFile(Handle : TbtfHandle; + BytesToRead : word; + var Buffer; + var BytesRead : word) : boolean; +var + DosError : word; +begin + asm + push ds + mov ah, $3F + mov bx, Handle + mov cx, BytesToRead + lds dx, Buffer + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + pop ds + jc @@Error + les di, BytesRead + mov es:[di], ax + xor ax, ax + @@Error: + mov DosError, ax + end; + baseReadFile := CheckForSuccess($3F00, DosError); +end; +{--------} +function baseWriteFile(Handle : TbtfHandle; + BytesToWrite : word; + var Buffer; + var BytesWritten : word) : boolean; +var + DosError : word; +begin + asm + push ds + mov ah, $40 + mov bx, Handle + mov cx, BytesToWrite + lds dx, Buffer + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + pop ds + jc @@Error + les di, BytesWritten + mov es:[di], ax + xor ax, ax + @@Error: + mov DosError, ax + end; + baseWriteFile := CheckForSuccess($4000, DosError); +end; +{--------------------------------------------------------------------} + +{---File access routines---------------------------------------------} +function btfCloseFile(aHandle : TbtfHandle) : boolean; +var + DosError : word; +begin + asm + mov ah, $3E + mov bx, aHandle + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + jc @@Error + xor ax, ax + @@Error: + mov DosError, ax + end; + btfCloseFile := CheckForSuccess($3E00, DosError); +end; +{--------} +function btfDeleteFile(aName : PAnsiChar) : boolean; +var + DosError : word; +begin + asm + push ds + mov ah, $41 + lds dx, aName + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + pop ds + jc @@Error + xor ax, ax + @@Error: + mov DosError, ax + end; + btfDeleteFile := CheckForSuccess($4100, DosError); +end; +{--------} +function btfFlushFile(aHandle : TbtfHandle) : boolean; +var + DosError : word; + DosFunc : word; +begin + asm + mov ax, $3000 {get DOS version} + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + cmp al, 3 {..major in al} + jg @@CommitCall + jl @@CloseDupCall + cmp ah, 30 {..minor in ah} + jge @@CommitCall + + @@CloseDupCall: {flush by dup'ing handle, closing dup} + mov ax, $4500 + mov DosFunc, ax + mov bx, aHandle + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + jc @@Error + mov bx, ax + mov ax, $3E00 + mov DosFunc, ax + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + jc @@Error + xor ax, ax + jmp @@Error + + @@CommitCall: {flush by using commit} + mov ax, $6800 + mov DosFunc, ax + mov bx, aHandle + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + jc @@Error + xor ax, ax + @@Error: + mov DosError, ax + end; + btfFlushFile := CheckForSuccess(DosFunc, DosError); +end; +{--------} +function btfGetPositionFile(aHandle : TbtfHandle; + var aOffset : DWORD) : boolean; {!!.54} +var + DosError : word; + SeekResult : longint; +begin + asm + mov ax, $4201 + mov bx, aHandle + xor cx, cx + xor dx, dx + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + jc @@Error + les di, aOffset + mov es:[di].word[2], dx + mov es:[di].word[0], ax + xor ax, ax + @@Error: + mov DosError, ax + end; + btfGetPositionFile := CheckForSuccess($4201, DosError); +end; +{--------} +function btfLockFile(aHandle : TbtfHandle; + aStart : longint; + aCount : longint) : boolean; +var + DosError : word; +begin + asm + mov ax, $5C00 + mov bx, aHandle + mov cx, aStart.word[2] + mov dx, aStart.word[0] + mov si, aCount.word[2] + mov di, aCount.word[0] + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + jc @@Error + xor ax, ax + @@Error: + mov DosError, ax + end; + btfLockFile := CheckForSuccess($5C00, DosError); +end; +{--------} +function btfOpenFile(aName : PAnsiChar; + aOpenMode : TbtfOpenMode; + aShareMode : TbtfShareMode; + aWriteThru : boolean; + aCreateFile : boolean; + aInheritable: boolean; + var aHandle : TbtfHandle) : boolean; +var + OpenMode : word; + CreateMode : word; + DosError : word; + DosFunc : word; + DosVer : word; +begin + {assume file won't open} + aHandle := INVALID_HANDLE_VALUE; + {$IFDEF DPMI} {!!.54} + {for protected mode, 'pretend' that the DOS version is 3.30: !!.54 + RTM.EXE does not support later DOS calls} {!!.54} + DosVer := $031E; {!!.54} + {$ELSE} {!!.54} + {get the DOS version (and get it the right way round)} + asm + mov ax, $3000 + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + xchg al, ah + mov DosVer, ax + end; + {$ENDIF} {!!.54} + {decide what to do based on the DOS version} + if (DosVer >= $0400) then begin + {initialise parameters to DOS open file function} + if (aOpenMode = bomReadOnly) then + OpenMode := OPEN_ACCESS_READONLY + else + OpenMode := OPEN_ACCESS_READWRITE; + if (aShareMode = bsmExclusive) then + OpenMode := OpenMode or OPEN_SHARE_DENYREADWRITE + else + OpenMode := OpenMode or OPEN_SHARE_DENYNONE; + if aWriteThru then + OpenMode := OpenMode or OPEN_FLAGS_COMMIT; + if not aInheritable then + OpenMode := OpenMode or OPEN_FLAGS_NOINHERIT; + OpenMode := OpenMode or OPEN_FLAGS_NOCRITERR; + if aCreateFile then + CreateMode := FILE_CREATE_ALWAYS + else + CreateMode := FILE_OPEN; + {open the file} + asm + push ds + mov ax, $6C00 + mov DosFunc, ax + mov bx, OpenMode + xor cx, cx + mov dx, CreateMode + lds si, aName + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + pop ds + jc @@Error + les di, aHandle + mov es:[di], ax + xor ax, ax + @@Error: + mov DosError, ax + end; + end + else {DOS version is less than 4.00} begin + if aCreateFile then {create the file} begin + asm + push ds + mov ax, $3C00 + mov DosFunc, ax + xor cx, cx {!!.54} + lds dx, aName + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + pop ds + jc @@Error + les di, aHandle + mov es:[di], ax + xor ax, ax + @@Error: + mov DosError, ax + end; + end + else {open the existing file} begin + {initialise parameters to DOS open file function} + if (aOpenMode = bomReadOnly) then + OpenMode := OPEN_ACCESS_READONLY + else + OpenMode := OPEN_ACCESS_READWRITE; + if (aShareMode = bsmExclusive) then + OpenMode := OpenMode or OPEN_SHARE_DENYREADWRITE + else + OpenMode := OpenMode or OPEN_SHARE_DENYNONE; + if not aInheritable then + OpenMode := OpenMode or OPEN_FLAGS_NOINHERIT; + {open the file} + asm + push ds + mov ax, OpenMode + mov ah, $3D + mov DosFunc, ax + lds dx, aName + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + pop ds + jc @@Error + les di, aHandle + mov es:[di], ax + xor ax, ax + @@Error: + mov DosError, ax + end; + end; + end; + btfOpenFile := CheckForSuccess(DosFunc, DosError); +end; +{--------} +function btfPositionFile(aHandle : TbtfHandle; + aOffset : longint) : boolean; +var + DosError : word; +begin + asm + mov ax, $4200 + mov bx, aHandle + mov cx, aOffset.word[2] + mov dx, aOffset.word[0] + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + jc @@Error + xor ax, ax + @@Error: + mov DosError, ax + end; + btfPositionFile := CheckForSuccess($4200, DosError); +end; +{--------} +function btfPositionFileEOF(aHandle : TbtfHandle; + var aFileSize : DWORD) : boolean; {!!.54} +var + DosError : word; + SeekResult : longint; + Offset : longint; +begin + asm + mov ax, $4202 + mov bx, aHandle + xor cx, cx + mov dx, cx + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + jc @@Error + les di, aFileSize + mov es:[di].word[2], dx + mov es:[di].word[0], ax + xor ax, ax + @@Error: + mov DosError, ax + end; + btfPositionFileEOF := CheckForSuccess($4202, DosError); +end; +{--------} +function btfReadFile(aHandle : TbtfHandle; + aToRead : longint; + var aBuffer; + var aBytesRead : longint) : boolean; +const + BlockSize = 32*1024; + {$IFDEF MSDOS} + SelectorInc = $1000; + {$ENDIF} +var + DestPtr : PAnsiChar; + BytesToGo : longint; + BytesToRead : word; + BytesRead : word; + MustIncSelector : boolean; +begin + btfReadFile := true; + aBytesRead := 0; + BytesToGo := aToRead; + DestPtr := @aBuffer; + + MustIncSelector := (Ofs(DestPtr^) >= BlockSize); + if ((Ofs(DestPtr^) mod BlockSize) <> 0) then begin + if MustIncSelector then + BytesToRead := MinLong(BytesToGo, succ($FFFF - Ofs(DestPtr^))) + else + BytesToRead := MinLong(BytesToGo, ($8000 - Ofs(DestPtr^))) + end + else begin + BytesToRead := MinLong(BytesToGo, BlockSize); + end; + if not baseReadFile(aHandle, BytesToRead, DestPtr^, BytesRead) then begin + btfReadFile := false; + Exit; + end; + inc(aBytesRead, BytesRead); + if (BytesToRead <> BytesRead) then + Exit; + dec(BytesToGo, BytesRead); + + while (BytesToGo > BlockSize) do begin + if MustIncSelector then + DestPtr := Ptr(Seg(DestPtr^) + SelectorInc, 0) + else + DestPtr := DestPtr + BytesRead; + MustIncSelector := not MustIncSelector; + BytesToRead := MinLong(BytesToGo, BlockSize); + if not baseReadFile(aHandle, BytesToRead, DestPtr^, BytesRead) then begin + btfReadFile := false; + Exit; + end; + inc(aBytesRead, BytesRead); + if (BytesToRead <> BytesRead) then + Exit; + dec(BytesToGo, BlockSize); + end; + if (BytesToGo <> 0) then begin + if MustIncSelector then + DestPtr := Ptr(Seg(DestPtr^) + SelectorInc, 0) + else + DestPtr := DestPtr + BytesRead; + if not baseReadFile(aHandle, BytesToGo, DestPtr^, BytesRead) then begin + btfReadFile := false; + Exit; + end; + inc(aBytesRead, BytesRead); + end; +end; +{--------} +function btfRenameFile(aName : PAnsiChar; + aNewName : PAnsiChar) : boolean; +var + DosError : word; +begin + asm + push ds + mov ah, $56 + lds dx, aName + les di, aNewName + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + pop ds + jc @@Error + xor ax, ax + @@Error: + mov DosError, ax + end; + btfRenameFile := CheckForSuccess($5600, DosError); +end; +{--------} +function btfSetEOF(aHandle : TbtfHandle; + aOffset : longint) : boolean; +var + DosError : word; +begin + if not btfPositionFile(aHandle, aOffset) then begin + btfSetEOF := false; + Exit; + end; + asm + push ds + mov ah, $40 + mov bx, aHandle + xor cx, cx + mov ds, cx + mov dx, cx + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + pop ds + jc @@Error + xor ax, ax + @@Error: + mov DosError, ax + end; + btfSetEOF := CheckForSuccess($4000, DosError); +end; +{--------} +function btfUnlockFile(aHandle : TbtfHandle; + aStart : longint; + aCount : longint) : boolean; +var + DosError : word; +begin + asm + mov ax, $5C01 + mov bx, aHandle + mov cx, aStart.word[2] + mov dx, aStart.word[0] + mov si, aCount.word[2] + mov di, aCount.word[0] + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + jc @@Error + xor ax, ax + @@Error: + mov DosError, ax + end; + btfUnlockFile := CheckForSuccess($5C01, DosError); +end; +{--------} +function btfWriteFile(aHandle : TbtfHandle; + aToWrite : longint; + const aBuffer; + var aBytesWritten : longint) : boolean; +const + BlockSize = 32*1024; + {$IFDEF MSDOS} + SelectorInc = $1000; + {$ENDIF} +var + SourcePtr : PAnsiChar; + BytesToGo : longint; + BytesToWrite: word; + BytesWrit : word; + MustIncSelector : boolean; +begin + btfWriteFile := true; + aBytesWritten := 0; + BytesToGo := aToWrite; + SourcePtr := @aBuffer; + + MustIncSelector := (Ofs(SourcePtr^) >= BlockSize); + if ((Ofs(SourcePtr^) mod BlockSize) <> 0) then begin + if MustIncSelector then + BytesToWrite := MinLong(BytesToGo, succ($FFFF - Ofs(SourcePtr^))) + else + BytesToWrite := MinLong(BytesToGo, ($8000 - Ofs(SourcePtr^))) + end + else begin + BytesToWrite := MinLong(BytesToGo, BlockSize); + end; + if not baseWriteFile(aHandle, BytesToWrite, SourcePtr^, BytesWrit) then begin + btfWriteFile := false; + Exit; + end; + inc(aBytesWritten, BytesWrit); + if (BytesToWrite <> BytesWrit) then + Exit; + dec(BytesToGo, BytesWrit); + + while (BytesToGo > BlockSize) do begin + if MustIncSelector then + SourcePtr := Ptr(Seg(SourcePtr^) + SelectorInc, 0) + else + SourcePtr := SourcePtr + BytesWrit; + MustIncSelector := not MustIncSelector; + BytesToWrite := MinLong(BytesToGo, BlockSize); + if not baseWriteFile(aHandle, BytesToWrite, SourcePtr^, BytesWrit) then begin + btfWriteFile := false; + Exit; + end; + inc(aBytesWritten, BytesWrit); + if (BytesToWrite <> BytesWrit) then + Exit; + dec(BytesToGo, BlockSize); + end; + if (BytesToGo <> 0) then begin + if MustIncSelector then + SourcePtr := Ptr(Seg(SourcePtr^) + SelectorInc, 0) + else + SourcePtr := SourcePtr + BytesWrit; + if not baseWriteFile(aHandle, BytesToGo, SourcePtr^, BytesWrit) then begin + btfWriteFile := false; + Exit; + end; + inc(aBytesWritten, BytesWrit); + end; +end; +{$ENDIF} +{====================================================================} + + +{===Win32 calls======================================================} +{$IFDEF Win32} +{$IFNDEF FPC} +function SetErrorCode(aDosFunc : word) : boolean; +begin + Result := false; + btfDOSFunc := aDosFunc; + btfDOSError := GetLastError; +end; +{--------} +function btfCloseFile(aHandle : TbtfHandle) : boolean; +begin + if not CloseHandle(aHandle) then + Result := SetErrorCode($3E00) + else + Result := true; +end; +{--------} +function btfDeleteFile(aName : PAnsiChar) : boolean; +begin + if not DeleteFile(aName) then + Result := SetErrorCode($4100) + else + Result := true; +end; +{--------} +function btfFlushFile(aHandle : TbtfHandle) : boolean; +begin + if not FlushFileBuffers(aHandle) then + Result := SetErrorCode($6800) + else + Result := true; +end; +{--------} +function btfGetPositionFile(aHandle : TbtfHandle; + var aOffset : DWORD) : boolean; {!!.54} +begin + aOffset := SetFilePointer(aHandle, 0, nil, FILE_CURRENT); + if (aOffset = $FFFFFFFF) then + Result := SetErrorCode($4201) + else + Result := true; +end; +{--------} +function btfLockFile(aHandle : TbtfHandle; + aStart : longint; + aCount : longint) : boolean; +begin + if not LockFile(aHandle, aStart, 0, aCount, 0) then + Result := SetErrorCode($5C00) + else + Result := true; +end; +{--------} +function btfOpenFile(aName : PAnsiChar; + aOpenMode : TbtfOpenMode; + aShareMode : TbtfShareMode; + aWriteThru : boolean; + aCreateFile : boolean; + aInheritable: boolean; + var aHandle : TbtfHandle) : boolean; +var + OpenMode : longint; + ShareMode : longint; + CreateMode : longint; + AttrFlags : longint; +begin + {initialise parameters to CreateFile} + if (aOpenMode = bomReadOnly) then + OpenMode := GENERIC_READ + else + OpenMode := GENERIC_READ or GENERIC_WRITE; + if (aShareMode = bsmExclusive) then + ShareMode := 0 + else + ShareMode := FILE_SHARE_READ or FILE_SHARE_WRITE; + if aCreateFile then + CreateMode := CREATE_ALWAYS + else + CreateMode := OPEN_EXISTING; + if aWriteThru then + AttrFlags := FILE_ATTRIBUTE_NORMAL or FILE_FLAG_WRITE_THROUGH + else + AttrFlags := FILE_ATTRIBUTE_NORMAL; + {the aInheritable flag is ignored} + {open the file} + aHandle := CreateFile(aName, + OpenMode, + ShareMode, + nil, {!! Security attrs} + CreateMode, + AttrFlags, + 0); + if (aHandle = INVALID_HANDLE_VALUE) then + Result := SetErrorCode($6C00) + else + Result := true; +end; +{--------} +function btfPositionFile(aHandle : TbtfHandle; + aOffset : longint) : boolean; +var + SeekResult : DWORD; {!!.54} +begin + SeekResult := SetFilePointer(aHandle, aOffset, nil, FILE_BEGIN); + if (SeekResult = $FFFFFFFF) then + Result := SetErrorCode($4200) + else + Result := true; +end; +{--------} +function btfPositionFileEOF(aHandle : TbtfHandle; + var aFileSize : DWORD) : boolean; {!!.54} +begin + aFileSize := SetFilePointer(aHandle, 0, nil, FILE_END); + if (aFileSize = $FFFFFFFF) then + Result := SetErrorCode($4202) + else + Result := true; +end; +{--------} +function btfReadFile(aHandle : TbtfHandle; + aToRead : longint; + var aBuffer; + var aBytesRead : longint) : boolean; +var + BR : DWORD; +begin + if not ReadFile(aHandle, aBuffer, aToRead, BR, nil) then + Result := SetErrorCode($3F00) + else begin + Result := true; + aBytesRead := BR; + end; +end; +{--------} +function btfRenameFile(aName : PAnsiChar; + aNewName : PAnsiChar) : boolean; +begin + if not MoveFile(aName, aNewName) then + Result := SetErrorCode($5600) + else + Result := true; +end; +{--------} +function btfSetEOF(aHandle : TbtfHandle; + aOffset : longint) : boolean; +begin + if not btfPositionFile(aHandle, aOffset) then begin + Result := false; + Exit; + end; + if not Windows.SetEndOfFile(aHandle) then + Result := SetErrorCode($4000) + else + Result := true; +end; +{--------} +function btfUnlockFile(aHandle : TbtfHandle; + aStart : longint; + aCount : longint) : boolean; +begin + if not UnlockFile(aHandle, aStart, 0, aCount, 0) then + Result := SetErrorCode($5C01) + else + Result := true; +end; +{--------} +function btfWriteFile(aHandle : TbtfHandle; + aToWrite : longint; + const aBuffer; + var aBytesWritten : longint) : boolean; +var + BW : DWORD; +begin + if not WriteFile(aHandle, aBuffer, aToWrite, BW, nil) then + Result := SetErrorCode($4000) + else begin + Result := true; + aBytesWritten := BW; + end; +end; +{$ENDIF} +{$ENDIF Win32} +{====================================================================} +{$ENDIF FPC outer ELSE} + +end. diff --git a/src/wc_sdk/btisbase.pas b/src/wc_sdk/btisbase.pas new file mode 100644 index 0000000..fcbbfa6 --- /dev/null +++ b/src/wc_sdk/btisbase.pas @@ -0,0 +1,942 @@ +{********************************************************************} +{* BTIsBase.PAS - B-Tree Filer ISAMBASE as unit *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * Rob Roberts robr@pcisys.net + * + * ***** END LICENSE BLOCK ***** *) + +{$I btdefine.inc} + +unit BTIsBase; + +interface + +uses + {$IFDEF FPC} + Dos, + {$ENDIF} + {$IFNDEF FPC} + {$IFDEF DPMI} + WinAPI, + {$ENDIF} + {$ENDIF} + {$IFDEF Win32} {!!.54} + Windows, {!!.54} + {$ENDIF} {!!.54} + {$IFDEF Windows} + WinTypes, WinProcs, + {$ENDIF} + {$IFDEF VER80} + SysUtils, + {$ENDIF} + {$IFNDEF Win32} + BaseSupp, + {$ENDIF} + {$IFDEF SupportVLM} {!!.54} + NWBase, NWFile, {!!.54} + {$ENDIF} {!!.54} + BTBase, + BTFileIO; + +const +{$IFDEF FPC} + IsamFileNameLen = 255; { Linux paths can exceed 64 chars } +{$ELSE} + IsamFileNameLen = 64; +{$ENDIF} + +type + IsamFileName = string[IsamFileNameLen]; + IsamHandle = TbtfHandle; + + IsamFile = packed record + Handle : TbtfHandle; + Name : array [0..IsamFileNameLen] of char; + IsLocal: boolean; {!!.54} + end; + + NetSupportType = (NoNet, Novell, MsNet); {Supported networks} + +var + IsamOK : boolean; {status of last operation} + IsamError : TbtfErrorCode; {error code of last operation} + IsamDOSFunc : word; {DOS function of last operation, if DOS was called} + IsamDOSError : TbtfErrorCode; {DOS error code of last operation, if failed} + IsamLockError: boolean; + IsamDefNrOfWS : Word; {!!.42} + +{$I filer.cfg} {configuration data} + +function IsamGetMem(var P; Size : TbtfMemSize) : boolean; + {-allocate memory, return true if successful} +procedure IsamDelay(MilliSecs : longint); + {-sleep a given amount of time} +function IsamInitNet(ExpectedNet : NetSupportType) : Boolean; + {-start up a network interface} +function IsamDoneNet : Boolean; + {-close down a network interface} + + +procedure IsamAssign(var F : IsamFile; FName : IsamFileName); + {-assigns FName to the file F} +procedure IsamBlockRead(var F : IsamFile; var Dest; Len : longint); + {-reads from the current position in a file} +procedure IsamBlockReadRetLen(var F : IsamFile; + var Dest; + Len : longint; + var BytesRead : longint); + {-reads from the current position in a file and returns the number + of bytes read} +procedure IsamBlockWrite(var F : IsamFile; var Source; Len : longint); + {-writes a block to the current position in a file} +procedure IsamClose(var F : IsamFile); + {-closes the file F} +procedure IsamDelete(var F : IsamFile); + {-Deletes the file F} +procedure IsamFlush(var F : IsamFile; + var WithDUP : Boolean; + NetUsed : Boolean); + {-Flushes the file F} +procedure IsamGetBlock(var F : IsamFile; + Ref, Len : LongInt; + var Dest); + {-reads from a given offset of a file} +function IsamGetPosition(var F : IsamFile) : LongInt; + {-returns the current position of the file F} +procedure IsamLongSeek(var F : IsamFile; Ref : LongInt); + {-seeks the position Ref in the file F} +procedure IsamLongSeekEOF(var F : IsamFile; var Len : DWORD); + {-seeks the end of file position in the file F and returns its length} +procedure IsamPutBlock(var F : IsamFile; + Ref, Len : LongInt; + var Source); + {-writes a block to the given offset in a file} +procedure IsamRename(var F : IsamFile; FName : IsamFileName); + {-Renames the file F to FName} +procedure IsamReset(var F : IsamFile; NetUsed, ReadOnly : Boolean); + {-opens the file F in the specified mode} +procedure IsamRewrite(var F : IsamFile); + {-creates the file F} +procedure IsamSetEOF(var F : IsamFile); + {-truncates the file F at the current file position} + + +{---Exported Lock Manager routines---} +function btfLockMgrAcqLock(aHandle : integer; + aOffset : longint; + aLength : longint; + aTimeOut : longint; + aTotalDelay : longint) : Boolean; + {-acquire a lock on a file} +function btfLockMgrRelLock(aHandle : integer; + aOffset : longint; + aLength : longint) : Boolean; + {-release a lock on a file} + +implementation + +{$IFDEF Win32} +uses + SysUtils; +{$ENDIF} + +type + IsamLockRecFunc = function (Start : Longint; + Len : LongInt; + Handle : IsamHandle; + TimeOut : word; + DelayTime : Word ) : Boolean; + IsamUnlockRecFunc = function (Start : LongInt; + Len : LongInt; + Handle : IsamHandle) : Boolean; + IsamExitNetFunc = function : Boolean; + +var + IsamLockRecord : IsamLockRecFunc; + IsamUnlockRecord : IsamUnlockRecFunc; + IsamExitNet : IsamExitNetFunc; + {$IFNDEF Win32} + ExitSave : pointer; + {$ENDIF} + +{===Helper routines==================================================} +{$IFNDEF UsingDelphi} +{$IFNDEF FPC} +type {!!.52} + THeapFunc = function (Size : word) : integer; {!!.52} +var {!!.52} + SaveHeapFunc : THeapFunc; {!!.52} +function IsamHeapFunc(Size : word) : integer; far; + begin + if Size <> 0 then + IsamHeapFunc := 1 + else {!!.52} + IsamHeapFunc := SaveHeapFunc(Size); {!!.52} + end; +{$ENDIF FPC} +{$ENDIF} +{--------} +procedure SetIsamDOSError; +begin + if (IsamDOSError = 0) then begin + IsamDOSFunc := btfDOSFunc; + IsamDOSError := btfDOSError; + end; +end; +{====================================================================} + + +{===Network support==================================================} +{$I isnetsup.inc} +{====================================================================} + + +{===Lock Manager=====================================================} +{$I btlckmgr.inc} +{====================================================================} + + +{===Primitive routines===============================================} +procedure IsamBlockReadRetLenPrim(var F : IsamFile; + var Dest; + Len : longint; + var BytesRead : longint); +begin + if not btfReadFile(F.Handle, Len, Dest, BytesRead) then begin + IsamOK := false; + case btfDOSError of + 6 : IsamError := 9904; + else + IsamError := 10140; + end;{case} + SetIsamDOSError; + BytesRead := 0; + end; +end; +{--------} +procedure IsamBlockReadPrim(var F : IsamFile; var Dest; Len : longint); +var + BytesRead : longint; +begin + IsamBlockReadRetLenPrim(F, Dest, Len, BytesRead); + if IsamOK and (BytesRead <> Len) then begin + IsamOK := false; + IsamError := 10070; + end; +end; +{--------} +procedure IsamGetBlockPrim(var F : IsamFile; Ref, Len : LongInt; var Dest); +begin + IsamLongSeek(F, Ref); + if not IsamOK then + Exit; + IsamBlockReadPrim(F, Dest, Len); +end; +{--------} +procedure IsamBlockWritePrim(var F : IsamFile; + var Source; + Len : longint); +var + BytesWritten : longint; +begin + if not btfWriteFile(F.Handle, Len, Source, BytesWritten) then begin + IsamOK := false; + case btfDOSError of + 6 : IsamError := 9904; + else + IsamError := 10140; + end;{case} + SetIsamDOSError; + end + else begin + if (BytesWritten <> Len) then begin + IsamOK := false; + IsamError := 10075; + end; + end; +end; +{--------} +procedure IsamPutBlockPrim(var F : IsamFile; Ref, Len : LongInt; var Source); +begin + IsamLongSeek(F, Ref); + if not IsamOK then Exit; + if (Len = 0) then {!!.53} + IsamSetEOF(F) {!!.53} + else {!!.53} + IsamBlockWritePrim(F, Source, Len); +end; +{====================================================================} + + +{===Non-file interfaced routines=====================================} +function IsamGetMem(var P; Size : TbtfMemSize) : boolean; +{$IFDEF FPC} +var + Pt : pointer absolute P; +begin + if (Size <= 0) then + Pt := nil + else begin + Pt := nil; + GetMem(Pt, Size); + end; + IsamGetMem := Pt <> nil; +end; +{$ELSE} +{$IFDEF Win32} +var + Pt : pointer absolute P; +begin + if (Size <= 0) then + Pt := nil + else + try + GetMem(Pt, Size); + except + on EOutOfMemory do + Pt := nil; + end;{try..except} + Result := Pt <> nil; +end; +{$ELSE} +{$IFDEF UsingDelphi} +var + Pt : pointer absolute P; +begin + if (Size = 0) then + Pt := nil + else + try + GetMem(Pt, Size); + except + on EOutOfMemory do + Pt := nil; + end;{try..except} + Result := Pt <> nil; +end; +{$ELSE} +var + Pt : pointer absolute P; +begin + SaveHeapFunc := THeapFunc(HeapError); {!!.52} + HeapError := @IsamHeapFunc; + GetMem(Pt, Size); + THeapFunc(HeapError) := SaveHeapFunc; {!!.52} + IsamGetMem := Pt <> nil; +end; +{$ENDIF} +{$ENDIF} +{$ENDIF FPC} +{--------} +procedure IsamDelay(MilliSecs : longint); +{$IFDEF FPC} +const + cTenSeconds = 10000; + cOneDay = LongInt(1000) * 60 * 60 * 24; +var + StartTime : longint; + EndTime : longint; + ThisTime : longint; + H, M, S, S100 : Word; + + function GetTimeNow : longint; + begin + Dos.GetTime(H, M, S, S100); + GetTimeNow := ((((((longint(H) * 60) + M) * 60) + S) * 100) + S100) * 10; + end; + +begin + if (MilliSecs > cTenSeconds) then + MilliSecs := cTenSeconds + else if (MilliSecs <= 0) then + Exit; + StartTime := GetTimeNow; + EndTime := StartTime + MilliSecs; + repeat + ThisTime := GetTimeNow; + { handle midnight rollover } + if (EndTime >= cOneDay) then begin + if (ThisTime < StartTime) then + ThisTime := ThisTime + cOneDay; + end; + until ThisTime >= EndTime; +end; +{$ELSE} +{$IFDEF Win32} +begin + Sleep(MilliSecs); +end; +{$ELSE} +const + NoCallCounter = -1; + CallCounter : longint = NoCallCounter; + cOneSecond = 1000; + cTenSeconds = 10000; + cOneDay = 1000 * 60 * 60 * 24; +var + StartTime : longint; + EndTime : longint; + ThisTime : longint; + ToCall : longint; + Counter : longint; + {------} + function GetTimeNow : longint; + var + H, M, S, T : byte; + begin + asm + mov ah, $2C + {$IFDEF DPMIOrWnd} + call DOS3Call + {$ELSE} + int $21 + {$ENDIF} + mov T, dl + mov S, dh + mov M, cl + mov H, ch + end; + GetTimeNow := ((((((longint(H) * 60) + M) * 60) + S) * 100) + T) * 10; + end; + {------} + function EndTimeIsLessThan(CompareTime : longint) : boolean; + begin + if (EndTime < cOneDay) then + EndTimeIsLessThan := EndTime < CompareTime + else if (CompareTime > StartTime) then + EndTimeIsLessThan := false + else + EndTimeIsLessThan := (EndTime - cOneDay) < CompareTime; + end; + {------} +begin + {do not delay beyond 10 seconds with this method} + if (MilliSecs > cTenSeconds) then + MilliSecs := cTenSeconds + {exit immediately if requested time is zero or less} + else if (MilliSecs <= 0) then + Exit; + {if we are initialising, get the count/tick} + if (CallCounter = NoCallCounter) then begin + {get start time} + StartTime := GetTimeNow; + {for initialisation, don't do more than 2 ticks} + MilliSecs := 80; + {get a time change} + repeat + ThisTime := GetTimeNow; + until (StartTime <> ThisTime); + {set start and end times} + StartTime := ThisTime; + EndTime := StartTime + MilliSecs; + Counter := 0; + repeat + inc(Counter); + if (Counter >= CallCounter) then + {Dummy to adjust speed}; + until EndTimeIsLessThan(GetTimeNow); + CallCounter := Counter; + end + {delay for the required time} + else begin + StartTime := GetTimeNow; + EndTime := StartTime + MilliSecs; + if (Millisecs > cOneSecond) then begin + repeat + {nothing} + until EndTimeIsLessThan(GetTimeNow); + end + else begin + ToCall := (Millisecs * CallCounter) div 110; + Counter := 0; + repeat + inc(Counter); + if EndTimeIsLessThan(GetTimeNow) then + {Dummy to delay}; + until Counter >= ToCall; + end; + end; +end; +{$ENDIF} +{$ENDIF FPC} +{====================================================================} + + +{===File interfaced routines=========================================} +procedure IsamAssign(var F : IsamFile; FName : IsamFileName); +begin + with F do begin + Handle := INVALID_HANDLE_VALUE; + Move(FName[1], Name[0], length(FName)); + Name[length(FName)] := #0; + end; +end; +{--------} +procedure IsamBlockRead(var F : IsamFile; var Dest; Len : longint); +var + Offset : longint; +begin + {work out the current file pointer} + Offset := IsamGetPosition(F); + if not IsamOK then Exit; + {call IsamGetBlock to read the data} + IsamGetBlock(F, Offset, Len, Dest); +end; +{--------} +procedure IsamBlockReadRetLen(var F : IsamFile; + var Dest; + Len : longint; + var BytesRead : longint); +{$IFNDEF NoNet} +var + Offset : longint; + Offset1 : longint; + Offset2 : longint; + Length1 : longint; + Length2 : longint; + LockedIt : boolean; + UnlockedIt : boolean; +{$ENDIF} +begin + {$IFNDEF NoNet} + LockedIt := false; + if DefeatLocalCache and not F.IsLocal then begin {!!.54} + Offset := IsamGetPosition(F); + if not IsamOK then Exit; + if btfLockMgrIsLockReq(F.Handle, + Offset, Len, + Offset1, Length1, + Offset2, Length2) then begin + if btfLockMgrAcqLock(F.Handle, Offset1, Length1, + IsamLockTimeOut, + IsamDelayBetwLocks) then begin + if (Length2 = 0) then begin + LockedIt := true; + end + else begin + if btfLockMgrAcqLock(F.Handle, Offset2, Length2, + IsamLockTimeOut, + IsamDelayBetwLocks) then begin + LockedIt := true + end + else begin + if btfLockMgrRelLock(F.Handle, Offset1, Length1) then + {do nothing}; + end; + end; + end; + if not LockedIt then begin + IsamOk := false; + IsamError := 10335; + Exit; + end; + end; + end; + {$ENDIF} + IsamBlockReadRetLenPrim(F, Dest, Len, BytesRead); + {$IFNDEF NoNet} + if LockedIt then begin + UnlockedIt := true; + if not btfLockMgrRelLock(F.Handle, Offset1, Length1) then + UnlockedIt := false; + if (Length2 <> 0) then + if not btfLockMgrRelLock(F.Handle, Offset2, Length2) then + UnlockedIt := false; + if not UnlockedIt then begin + if IsamOk then begin + IsamOk := false; + IsamError := 10345; + end; + end; + end; + {$ENDIF} +end; +{--------} +procedure IsamBlockWrite(var F : IsamFile; var Source; Len : longint); +var + Offset : longint; +begin + {work out the current file pointer} + Offset := IsamGetPosition(F); + if not IsamOK then Exit; + {call IsamPutBlock to write the data} + IsamPutBlock(F, Offset, Len, Source); +end; +{--------} +procedure IsamClose(var F : IsamFile); +begin + btfLockMgrRelAllLocks(F.Handle); + if not btfCloseFile(F.Handle) then begin + IsamOK := false; + case btfDOSError of + 6 : IsamError := 9904; + else + IsamError := 10140; + end;{case} + SetIsamDOSError; + end + else + F.Handle := INVALID_HANDLE_VALUE; +end; +{--------} +procedure IsamDelete(var F : IsamFile); +begin + if not btfDeleteFile(F.Name) then begin + IsamOK := false; + case btfDOSError of + 2 : IsamError := 9903; + 3 : IsamError := 9900; + 53 : IsamError := 9900; {!!.57} + else + IsamError := 10140; + end;{case} + SetIsamDOSError; + end; +end; +{--------} +procedure IsamFlush(var F : IsamFile; + var WithDUP : Boolean; + NetUsed : Boolean); +begin + WithDUP := true; + if not btfFlushFile(F.Handle) then begin + if (btfDOSError = 4) then begin + {a dup was attempted, but there's too many open files} + WithDUP := false; + if NetUsed then begin + IsamOK := False; + IsamError := 10150; + SetIsamDOSError; + end + else begin + IsamClose(F); + if not IsamOK then + Exit; + IsamReset(F, False, False); + end; + end + else begin + IsamOK := false; + case btfDOSError of + 6 : IsamError := 9904; + else + IsamError := 10140; + end;{case} + SetIsamDOSError; + end; + end; +end; +{--------} +procedure IsamGetBlock(var F : IsamFile; + Ref, Len : LongInt; + var Dest); +{$IFNDEF NoNet} +var + Offset1 : longint; + Offset2 : longint; + Length1 : longint; + Length2 : longint; + LockedIt : boolean; + UnlockedIt : boolean; +{$ENDIF} +begin + {$IFNDEF NoNet} + LockedIt := false; + if DefeatLocalCache and not F.IsLocal then begin {!!.54} + if btfLockMgrIsLockReq(F.Handle, + Ref, Len, + Offset1, Length1, + Offset2, Length2) then begin + if btfLockMgrAcqLock(F.Handle, Offset1, Length1, + IsamLockTimeOut, + IsamDelayBetwLocks) then begin + if (Length2 = 0) then begin + LockedIt := true; + end + else begin + if btfLockMgrAcqLock(F.Handle, Offset2, Length2, + IsamLockTimeOut, + IsamDelayBetwLocks) then begin + LockedIt := true + end + else begin + if btfLockMgrRelLock(F.Handle, Offset1, Length1) then + {do nothing}; + end; + end; + end; + if not LockedIt then begin + IsamOk := false; + IsamError := 10335; + Exit; + end; + end; + end; + {$ENDIF} + IsamGetBlockPrim(F, Ref, Len, Dest); + {$IFNDEF NoNet} + if LockedIt then begin + UnlockedIt := true; + if not btfLockMgrRelLock(F.Handle, Offset1, Length1) then + UnlockedIt := false; + if (Length2 <> 0) then + if not btfLockMgrRelLock(F.Handle, Offset2, Length2) then + UnlockedIt := false; + if not UnlockedIt then begin + if IsamOk then begin + IsamOk := false; + IsamError := 10345; + end; + end; + end; + {$ENDIF} +end; +{--------} +function IsamGetPosition(var F : IsamFile) : LongInt; +var + Offset : DWORD; {!!.54} +begin + if not btfGetPositionFile(F.Handle, Offset) then begin + IsamOK := false; + case btfDOSError of + 6 : IsamError := 9904; + else + IsamError := 10140; + end;{case} + SetIsamDOSError; + IsamGetPosition := -1; + end + else + IsamGetPosition := Offset; +end; +{--------} +procedure IsamLongSeek(var F : IsamFile; Ref : LongInt); +begin + if not btfPositionFile(F.Handle, Ref) then begin + IsamOK := false; + case btfDOSError of + 6 : IsamError := 9904; + else + IsamError := 10140; + end;{case} + SetIsamDOSError; + end; +end; +{--------} +procedure IsamLongSeekEOF(var F : IsamFile; var Len : DWORD); +begin + if not btfPositionFileEOF(F.Handle, Len) then begin + IsamOK := false; + case btfDOSError of + 6 : IsamError := 9904; + else + IsamError := 10140; + end;{case} + SetIsamDOSError; + end; +end; +{--------} +procedure IsamPutBlock(var F : IsamFile; + Ref, Len : LongInt; + var Source); +{$IFNDEF NoNet} +var + Offset1 : longint; + Offset2 : longint; + Length1 : longint; + Length2 : longint; + LockedIt : boolean; + UnlockedIt : boolean; +{$ENDIF} +begin + {$IFNDEF NoNet} + LockedIt := false; + if DefeatLocalCache and (Len <> 0) and not F.IsLocal then begin {!!.54} + if btfLockMgrIsLockReq(F.Handle, + Ref, Len, + Offset1, Length1, + Offset2, Length2) then begin + if btfLockMgrAcqLock(F.Handle, Offset1, Length1, + IsamLockTimeOut, + IsamDelayBetwLocks) then begin + if (Length2 = 0) then begin + LockedIt := true; + end + else begin + if btfLockMgrAcqLock(F.Handle, Offset2, Length2, + IsamLockTimeOut, + IsamDelayBetwLocks) then begin + LockedIt := true + end + else begin + if btfLockMgrRelLock(F.Handle, Offset1, Length1) then + {do nothing}; + end; + end; + end; + if not LockedIt then begin + IsamOk := false; + IsamError := 10335; + Exit; + end; + end; + end; + {$ENDIF} + IsamPutBlockPrim(F, Ref, Len, Source); + {$IFNDEF NoNet} + if LockedIt then begin + UnlockedIt := true; + if not btfLockMgrRelLock(F.Handle, Offset1, Length1) then + UnlockedIt := false; + if (Length2 <> 0) then + if not btfLockMgrRelLock(F.Handle, Offset2, Length2) then + UnlockedIt := false; + if not UnlockedIt then begin + if IsamOk then begin + IsamOk := false; + IsamError := 10345; + end; + end; + end; + {$ENDIF} +end; +{--------} +procedure IsamRename(var F : IsamFile; FName : IsamFileName); +var + NameZ : array [0..IsamFileNameLen] of char; +begin + Move(FName[1], NameZ[0], length(FName)); + NameZ[length(FName)] := #0; + if not btfRenameFile(F.Name, NameZ) then begin + IsamOK := false; + case btfDOSError of + 2 : IsamError := 9903; + 3 : IsamError := 9900; + 53 : IsamError := 9900; {!!.57} + else + IsamError := 10140; + end;{case} + SetIsamDOSError; + end; +end; +{--------} +procedure IsamReset(var F : IsamFile; NetUsed, ReadOnly : Boolean); +var + OpenMode : TbtfOpenMode; + ShareMode : TbtfShareMode; +begin + if ReadOnly then + OpenMode := bomReadOnly + else + OpenMode := bomReadWrite; + if NetUsed then + ShareMode := bsmShared + else + ShareMode := bsmExclusive; + if not btfOpenFile(F.Name, OpenMode, ShareMode, + false, false, InheritFileHandles, F.Handle) then begin + IsamOK := false; + case btfDOSError of + 2 : IsamError := 9903; + 3 : IsamError := 9900; + 4 : IsamError := 9901; + 12 : IsamError := 9908; + 53 : IsamError := 9900; {!!.57} + else + IsamError := 10140; + end;{case} + SetIsamDOSError; + end + else begin {!!.54} + F.IsLocal := not NetUsed; {!!.54} + end; {!!.54} +end; +{--------} +procedure IsamRewrite(var F : IsamFile); +begin + if not btfOpenFile(F.Name, bomReadWrite, bsmExclusive, + false, true, InheritFileHandles, F.Handle) then begin + IsamOK := false; + case btfDOSError of + 3 : IsamError := 9900; + 4 : IsamError := 9901; + 53 : IsamError := 9900; {!!.57} + else + IsamError := 10140; + end;{case} + SetIsamDOSError; + end {!!.54} + else begin {!!.54} + F.IsLocal := true; {!!.54} + end; +end; +{--------} +procedure IsamSetEOF(var F : IsamFile); +var + Offset : longint; +begin + Offset := IsamGetPosition(F); + if not IsamOK then Exit; + if not btfSetEOF(F.Handle, Offset) then begin + IsamOK := false; + case btfDOSError of + 6 : IsamError := 9904; + else + IsamError := 10140; + end;{case} + SetIsamDOSError; + end; +end; + +procedure BTIsBaseUnitDone; far; +begin + btfLockMgrDestroy; + {$IFNDEF Win32} + ExitProc := ExitSave; + {$ENDIF} +end; + +procedure BTIsBaseUnitInit; +begin + btfLockMgrCreate; + {$IFNDEF Win32} + ExitSave := ExitProc; + ExitProc := @BTIsBaseUnitDone; + {$ENDIF} +end; + +{$IFDEF Win32} +initialization + BTIsBaseUnitInit; + +finalization + BTIsBaseUnitDone; +{$ELSE} +begin + BTIsBaseUnitInit; +{$ENDIF} + +end. diff --git a/src/wc_sdk/btlckmgr.inc b/src/wc_sdk/btlckmgr.inc new file mode 100644 index 0000000..773d5b0 --- /dev/null +++ b/src/wc_sdk/btlckmgr.inc @@ -0,0 +1,737 @@ +{********************************************************************} +{* BTLCKMGR.INC - lock manager *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{Notes: + the lock manager interfaces between B-Tree Filer high level routines + and the operating system physical locks. The lock + manager performs the following actions: + - tracks all locks acquired and released for all + files, + - reference counts locks so that you can place the + same lock several times, + - enables all locks for a file handle to be + released. + - provides a way to determine whether a lock is + required or not, and if so returns the sub-locks + that need to be placed (this helps for the new + requirement that regions must be locked before + they are read from/written to). + The lock manager is not an object/class (the reason + is that BTF can be used by compilers that have + different object models) but is instead a global + variable (btfLocks) and a set of routines that act + on that variable). + btfLockMgrAcqLock is a high level routine that gets another lock for + a file handle; if the lock already exists as a + lock item, the count is incremented; if not a new + lock is physically placed and a new lock item is + added to the list. + btfLockMgrRelLock is a high level routine that releases a lock for + a file handle; the count for the lock item is + decremented and if it reaches zero the lock is + physically released and the lock item is removed + from the list. + btfLockMgrLockExists is a high level routine that returns true if + the lock exists in the list + btfLockMgrRelAllLocks is a high level routine that releases all + locks for a file handle + btfLockMgrIsLockReq is a high level routine that determines whether + a lock is required or not; if a lock is required + then it returns true with the parameters of up + to two sub-locks required; if not it returns + false (please see extra notes below). + btfLockMgrCreate is a high level routine that sets up the + btfFileLocks list. + btfLockMgrDestroy is a high level routine that frees the + btfFileLocks list; no locks are physically + released, this routine is designed to be called at + program termination to release the list memory + back to the heap manager and it is assumed that + all locks will have already been released. + Errors. The lock manager can return 5 error codes in variable + btfLockMgrError: + btferrLockMgrCannotAllocList - + not enough memory to allocate a new file or lock + list, or the maximum number of files or locks per + file has been exceeded + btferrLockMgrLockLenMismatch - + an attempt was made to allocate a lock that + partially overlaps an existing one + btferrLockMgrLockNotFound - + an attempt was made to release a lock that doesn't + appear in the lock list + btferrLockMgrCannotLock - + the call to IsamLockRecord failed + btferrLockMgrCannotUnlock - + the call to IsamUnlockRecord failed + } + +const + btfcMaxFiles = 4000; {max. number of file handles that can be tracked} + btfcMaxLocks = 4000; {max. number of locks per file that can be tracked} + btfcLockDelta = 50; + btfcFileDelta = 25; + + btferrLockMgrSuccess = 0; + btferrLockMgrCannotAllocList = 1; + btferrLockMgrLockLenMismatch = 2; + btferrLockMgrLockNotFound = 3; + btferrLockMgrCannotLock = 4; + btferrLockMgrCannotUnlock = 5; + +type + PbtfLockItem = ^TbtfLockItem; + TbtfLockItem = record + bliOffset : longint; {offset in file} + bliLength : longint; {length of lock} + bliCount : integer; {count of locks} + end; + PbtfLockArray = ^TbtfLockArray; + TbtfLockArray = record + blaMaxCount : integer; {maximum count of locks, 0..btfcMaxLocks} + blaCount : integer; {current count of locks} + blaLocks : array [0..pred(btfcMaxLocks)] of TbtfLockItem; + end; + PbtfFileItem = ^TbtfFileItem; + TbtfFileItem = record + bfiHandle : integer; {file handle} + bfiLocks : PbtfLockArray; {array of locks for file} + end; + PbtfFileArray = ^TbtfFileArray; + TbtfFileArray = record + bfaMaxCount : integer; {maximum count of files, 0..btfcMaxFiles} + bfaCount : integer; {current count of files} + bfaFiles : array [0..pred(btfcMaxFiles)] of TbtfFileItem; + end; + +var + btfFileLocks : PbtfFileArray; + btfLockMgrError : integer; + +{===Lock Manager Routines============================================} +function btfLockMgrCalcFileArraySize(aFileCount : integer) : longint; + {-calculate the memory size for a file array} +begin + btfLockMgrCalcFileArraySize := + (2 * sizeof(integer)) + (longint(aFileCount) * sizeof(TbtfFileItem)); +end; +{--------} +function btfLockMgrCalcLockArraySize(aLockCount : integer) : longint; + {-calculate the memory size for a lock array} +begin + btfLockMgrCalcLockArraySize := + (2 * sizeof(integer)) + (longint(aLockCount) * sizeof(TbtfLockItem)); +end; +{--------} +function btfLockMgrResizeFileArray(var aFileArray : PbtfFileArray; + aFileCount : integer) : Boolean; + {-resize a file array to hold more files} +var + OldSize : longint; + NewFileArray : PbtfFileArray; +begin + btfLockMgrResizeFileArray := false; + if (aFileArray = nil) then begin + if (aFileCount <= btfcFileDelta) then + aFileCount := btfcFileDelta; + end + else begin + if (aFileCount <= aFileArray^.bfaMaxCount) then + aFileCount := aFileArray^.bfaMaxCount + btfcFileDelta; + end; + if (aFileCount > btfcMaxFiles) or + (not IsamGetMem(NewFileArray, btfLockMgrCalcFileArraySize(aFileCount))) then begin + btfLockMgrError := btferrLockMgrCannotAllocList; + Exit; + end; + if (aFileArray <> nil) then {a previous file array exists} begin + OldSize := btfLockMgrCalcFileArraySize(aFileArray^.bfaMaxCount); + Move(aFileArray^, NewFileArray^, OldSize); + FreeMem(aFileArray, OldSize); + end + else {no previous file array} begin + NewFileArray^.bfaCount := 0; + end; + NewFileArray^.bfaMaxCount := aFileCount; + aFileArray := NewFileArray; + btfLockMgrResizeFileArray := true; +end; +{--------} +function btfLockMgrResizeLockArray(var aLockArray : PbtfLockArray; + aLockCount : integer) : Boolean; + {-resize a lock array to hold more locks} +var + OldSize : longint; + NewLockArray : PbtfLockArray; +begin + btfLockMgrResizeLockArray := false; + if (aLockArray = nil) then begin + if (aLockCount <= btfcLockDelta) then + aLockCount := btfcLockDelta; + end + else begin + if (aLockCount <= aLockArray^.blaMaxCount) then + aLockCount := aLockArray^.blaMaxCount + btfcLockDelta; + end; + if (aLockCount > btfcMaxLocks) or + (not IsamGetMem(NewLockArray, btfLockMgrCalcLockArraySize(aLockCount))) then begin + btfLockMgrError := btferrLockMgrCannotAllocList; + Exit; + end; + if (aLockArray <> nil) then {a previous lock array exists} begin + OldSize := btfLockMgrCalcLockArraySize(aLockArray^.blaMaxCount); + Move(aLockArray^, NewLockArray^, OldSize); + FreeMem(aLockArray, OldSize); + end + else {no previous lock array} begin + NewLockArray^.blaCount := 0; + end; + NewLockArray^.blaMaxCount := aLockCount; + aLockArray := NewLockArray; + btfLockMgrResizeLockArray := true; +end; +{--------} +function btfLockMgrFindFile(aFileArray : PbtfFileArray; + aHandle : integer; + var aInx : integer) : boolean; + {-find a file handle in a file array} +var + L, R, M : integer; + FileHandle : integer; +begin + {simple case - nothing there} + if (aFileArray = nil) or (aFileArray^.bfaCount = 0) then begin + btfLockMgrFindFile := false; + aInx := 0; + Exit; + end; + {binary search} + L := 0; + R := pred(aFileArray^.bfaCount); + repeat + M := (L + R) div 2; + FileHandle := aFileArray^.bfaFiles[M].bfiHandle; + if (aHandle < FileHandle) then + R := pred(M) + else if (aHandle > FileHandle) then + L := succ(M) + else begin + btfLockMgrFindFile := true; + aInx := M; + Exit; + end; + until (L > R); + aInx := L; + btfLockMgrFindFile := false; +end; +{--------} +function btfLockMgrFindLock(aLockArray : PbtfLockArray; + aOffset : longint; + var aInx : integer) : boolean; + {-find a lock (defined by its offset) in a lock array} +var + L, R, M : integer; + LockOfs : longint; +begin + {simple case - no locks} + if (aLockArray = nil) or (aLockArray^.blaCount = 0) then begin + btfLockMgrFindLock := false; + aInx := 0; + Exit; + end; + {binary search} + L := 0; + R := pred(aLockArray^.blaCount); + repeat + M := (L + R) div 2; + LockOfs := aLockArray^.blaLocks[M].bliOffset; + if (aOffset < LockOfs) then + R := pred(M) + else if (aOffset > LockOfs) then + L := succ(M) + else begin + btfLockMgrFindLock := true; + aInx := M; + Exit; + end; + until (L > R); + aInx := L; + btfLockMgrFindLock := false; +end; +{--------} +procedure btfLockMgrInsertFileItem(aFileArray : PbtfFileArray; + aInx : integer; + aHandle : longint); + {-insert a new file item in a file array} +begin + with aFileArray^ do begin + if (aInx < bfaCount) then begin + Move(bfaFiles[aInx], + bfaFiles[aInx+1], + (bfaCount - aInx) * sizeof(TbtfFileItem)); + end; + with bfaFiles[aInx] do begin + bfiHandle := aHandle; + bfiLocks := nil; + btfLockMgrResizeLockArray(bfiLocks, btfcLockDelta); + end; + inc(bfaCount); + end; +end; +{--------} +procedure btfLockMgrInsertLockItem(aLockArray : PbtfLockArray; + aInx : integer; + aOffset : longint; + aLength : longint); + {-insert a new lock item in a lock array} +begin + with aLockArray^ do begin + if (aInx < blaCount) then begin + Move(blaLocks[aInx], + blaLocks[aInx+1], + (blaCount - aInx) * sizeof(TbtfLockItem)); + end; + with blaLocks[aInx] do begin + bliOffset := aOffset; + bliLength := aLength; + bliCount := 1; + end; + inc(blaCount); + end; +end; +{--------} +procedure btfLockMgrRemoveFileItem(aFileArray : PbtfFileArray; + aInx : integer); + {-remove a file item from a file array} +begin + with aFileArray^ do begin + {free the file's lock array, if required} + with bfaFiles[aInx] do begin + if (bfiLocks <> nil) then + FreeMem(bfiLocks, + btfLockMgrCalcLockArraySize(bfiLocks^.blaMaxCount)); + end; + {close up the hole held by the file} + dec(bfaCount); + if (aInx < bfaCount) then begin + Move(bfaFiles[aInx+1], + bfaFiles[aInx], + (bfaCount - aInx) * sizeof(TbtfFileItem)); + end; + end; +end; +{--------} +procedure btfLockMgrRemoveLockItem(aLockArray : PbtfLockArray; + aInx : integer); + {-remove a lock item from a lock array} +begin + with aLockArray^ do begin + dec(blaCount); + if (aInx < blaCount) then begin + Move(blaLocks[aInx+1], + blaLocks[aInx], + (blaCount - aInx) * sizeof(TbtfLockItem)); + end; + end; +end; +{--------} +function btfLockMgrAcqLock(aHandle : integer; + aOffset : longint; + aLength : longint; + aTimeOut : longint; + aTotalDelay : longint) : Boolean; +var + LockInx : integer; + FileInx : integer; + LockArray : PbtfLockArray; + FoundIt : boolean; +begin + {Assumption: if a lock already exists the length of the lock that is + being acquired must equal the length of the lock in the + lock list, otherwise an error is generated} + + btfLockMgrError := btferrLockMgrSuccess; + btfLockMgrAcqLock := false; + {create the file array, if required; add the first item} + if (btfFileLocks = nil) then begin + if not btfLockMgrResizeFileArray(btfFileLocks, btfcFileDelta) then + Exit; + btfLockMgrInsertFileItem(btfFileLocks, 0, aHandle); + FileInx := 0; + end + {otherwise, find the index of the file item for the given handle; + create it, if required (remember to check for resizing the file + array)} + else begin + if not btfLockMgrFindFile(btfFileLocks, aHandle, FileInx) then begin + with btfFileLocks^ do begin + if (bfaCount = bfaMaxCount) then begin + if not btfLockMgrResizeFileArray(btfFileLocks, + bfaMaxCount + btfcFileDelta) then + Exit; + end; + end; + btfLockMgrInsertFileItem(btfFileLocks, FileInx, aHandle); + end; + end; + + {create the lock array for this file item, if required} + LockArray := btfFileLocks^.bfaFiles[FileInx].bfiLocks; + with LockArray^ do begin + {check whether there's room in the lock array} + if (blaCount = blaMaxCount) then begin + if not btfLockMgrResizeLockArray(btfFileLocks^.bfaFiles[FileInx].bfiLocks, + blaMaxCount + btfcLockDelta) then + Exit; + LockArray := btfFileLocks^.bfaFiles[FileInx].bfiLocks; + end; + + {get the nearest lock (as defined by offset); if the lock is there + return true and the element number, if not return false and the + element number where it should be inserted} + FoundIt := btfLockMgrFindLock(LockArray, aOffset, LockInx); + + {if it already exists, increment the lock count} + if FoundIt then begin + if (aLength <> blaLocks[LockInx].bliLength) then begin + btfLockMgrError := btferrLockMgrLockLenMismatch; + Exit; + end; + inc(blaLocks[LockInx].bliCount); + end + {if the lock doesn't exist, add it} + else begin + if IsamLockRecord(aOffset, aLength, aHandle, aTimeOut, aTotalDelay) then + btfLockMgrInsertLockItem(LockArray, LockInx, aOffset, aLength) + else begin + btfLockMgrError := btferrLockMgrCannotLock; + Exit; + end; + end; + end; + btfLockMgrAcqLock := true; +end; +{--------} +function btfLockMgrRelLock(aHandle : integer; + aOffset : longint; + aLength : longint) : Boolean; +var + LockInx : integer; + FileInx : integer; + LockArray : PbtfLockArray; + FoundIt : boolean; +begin + {Assumption: if a lock already exists the length of the lock that is + being released must equal the length of the lock in the + lock list, otherwise an error is generated} + btfLockMgrError := btferrLockMgrSuccess; + btfLockMgrRelLock := false; + FoundIt := btfLockMgrFindFile(btfFileLocks, aHandle, FileInx); + {if the file doesn't exist, report lock not found error} + if not FoundIt then begin + btfLockMgrError := btferrLockMgrLockNotFound; + Exit; + end; + {the file was found} + LockArray := btfFileLocks^.bfaFiles[FileInx].bfiLocks; + with LockArray^ do begin + {get the nearest lock (as defined by handle/offset); if the lock + is there return true and the element number, if not return false} + FoundIt := btfLockMgrFindLock(LockArray, aOffset, LockInx); + + {if it already exists, decrement the lock count; if the lock count + goes to zero, remove the lock and the lock item} + if FoundIt then begin + if (aLength <> blaLocks[LockInx].bliLength) then begin + btfLockMgrError := btferrLockMgrLockLenMismatch; + Exit; + end; + if (blaLocks[LockInx].bliCount = 1) then begin + if IsamUnlockRecord(aOffset, aLength, aHandle) then + btfLockMgrRemoveLockItem(LockArray, LockInx) + else begin + btfLockMgrError := btferrLockMgrCannotUnlock; + Exit; + end; + end + else begin + dec(blaLocks[LockInx].bliCount); + end; + end + {if the lock doesn't exist, report error} + else begin + btfLockMgrError := btferrLockMgrLockNotFound; + Exit; + end; + end; + btfLockMgrRelLock := true; +end; +{--------} +function btfLockMgrLockExists(aHandle : integer; + aOffset : longint; + aLength : longint) : boolean; +var + LockInx : integer; + FileInx : integer; + LockArray : PbtfLockArray; + FoundIt : boolean; +begin + {Assumption: if a lock already exists the length of the lock that is + being queried must equal the length of the lock in the + lock list, otherwise an error is generated} + btfLockMgrError := btferrLockMgrSuccess; + FoundIt := btfLockMgrFindFile(btfFileLocks, aHandle, FileInx); + if FoundIt then begin + LockArray := btfFileLocks^.bfaFiles[FileInx].bfiLocks; + FoundIt := btfLockMgrFindLock(LockArray, aOffset, LockInx); + if FoundIt then begin + if (aLength <> LockArray^.blaLocks[LockInx].bliLength) then begin + btfLockMgrError := btferrLockMgrLockLenMismatch; + FoundIt := false; {ie, it doesn't count if wrong length} + end; + end; + end; + btfLockMgrLockExists := FoundIt; +end; +{--------} +function btfLockMgrRelAllLocks(aHandle : integer) : Boolean; +var + LockInx : integer; + FileInx : integer; + LockArray : PbtfLockArray; +begin + btfLockMgrError := btferrLockMgrSuccess; + btfLockMgrRelAllLocks := false; + if btfLockMgrFindFile(btfFileLocks, aHandle, FileInx) then begin + LockArray := btfFileLocks^.bfaFiles[FileInx].bfiLocks; + {release all locks for this handle, by continually removing the + lock at the end of the list until there are no more; by doing + this from the end ensures a more efficient routine} + with LockArray^ do begin + for LockInx := pred(blaCount) downto 0 do begin + with blaLocks[LockInx] do begin + if IsamUnlockRecord(bliOffset, bliLength, aHandle) then + btfLockMgrRemoveLockItem(LockArray, LockInx) + else begin + btfLockMgrError := btferrLockMgrCannotUnlock; + Exit; + end; + end; + end; + end; + btfLockMgrRemoveFileItem(btfFileLocks, FileInx); + end; + btfLockMgrRelAllLocks := true; +end; +{--------} +function btfLockMgrIsLockReq(aHandle : integer; + aReqOffset : longint; + aReqLength : longint; + var aOffset1 : longint; + var aLength1 : longint; + var aOffset2 : longint; + var aLength2 : longint) : boolean; + {------} + function ReqLockIntersects(LockArray : PbtfLockArray; + aLockInx : integer) : boolean; + begin + with LockArray^.blaLocks[aLockInx] do + ReqLockIntersects := + ((bliOffset <= aReqOffset) and (aReqOffset < (bliOffset + bliLength))) or + ((aReqOffset <= bliOffset) and (bliOffset < (aReqOffset + aReqLength))); + end; + {------} +var + LockInx : integer; + FileInx : integer; + Inx : integer; + NextLockInx : integer; + LockCount : integer; + CheckOffset : longint; + SubLockToUse: integer; + LockArray : PbtfLockArray; + FoundIt : boolean; + CurrentLockIntersects : boolean; +begin + {Notes: the reason for this routine is to determine whether a lock + is required and is used by the safe read/write routines + (those which only read/write from a locked region, to combat + the latest Win32 Microsoft caching problems). The routine + attempts to see whether (1) the full lock has already been + placed (in which case no lock is required) or (2) at least + part of the lock region is already locked. In this second + case, analysis of the standard B-Tree Filer locking method- + ology has shown that this already-locked part is either at + the front of the required region, at the back or in the + middle. Hence only one or at most two sub-locks need to be + placed to ensure the entire region is locked, and this + routine will return those one or two sub-locks required. + + If the routine returns false, no lock(s) is/are required. + + If the routine returns true, at least one lock is required. + and maybe two. The first lock is given by aOffset1/aLength1. + If aLength2 is zero, no second sub-lock is required, other- + wise aOffset2/aLength2 determines the second sub-lock.} + + {assume no sublocks are required} + btfLockMgrIsLockReq := false; + aOffset1 := 0; + aLength1 := 0; + aOffset2 := 0; + aLength2 := 0; + + {check to see whether the file lock list is empty, if it is then + obviously the lock will be required} + if (btfFileLocks = nil) or (btfFileLocks^.bfaCount = 0) then begin + btfLockMgrIsLockReq := true; + aOffset1 := aReqOffset; + aLength1 := aReqLength; + Exit; + end; + + {get the file item for this handle, if not found or if the file's + lock list is empty then the lock is required} + FoundIt := btfLockMgrFindFile(btfFileLocks, aHandle, FileInx); + if (not FoundIt) or + (btfFileLocks^.bfaFiles[FileInx].bfiLocks^.blaCount = 0) then begin + btfLockMgrIsLockReq := true; + aOffset1 := aReqOffset; + aLength1 := aReqLength; + Exit; + end; + + LockArray := btfFileLocks^.bfaFiles[FileInx].bfiLocks; + with LockArray^ do begin + {get the nearest lock (as defined by handle/offset); if the lock + is there return true and the element number, if not return false} + FoundIt := btfLockMgrFindLock(LockArray, aReqOffset, LockInx); + + {while the previous lock in the list is for the same handle and + intersects our required region, decrement the lock index: ie, + find the first lock in the series that intersects our region} + if FoundIt then begin + CurrentLockIntersects := true; + end + else begin + if (LockInx = blaCount) then + CurrentLockIntersects := false + else + CurrentLockIntersects := ReqLockIntersects(LockArray, LockInx); + while (LockInx > 0) and + ReqLockIntersects(LockArray, pred(LockInx)) do begin + dec(LockInx); + CurrentLockIntersects := true; + end; + end; + + {if the current lock (as defined by LockInx) intersects our + region, count the succeeding locks in the list that are for the + same handle and that intersect our required region} + if CurrentLockIntersects then begin + NextLockInx := succ(LockInx); + while (NextLockInx < blaCount) and + ReqLockIntersects(LockArray, NextLockInx) do + inc(NextLockInx); + LockCount := NextLockInx - LockInx; + end + {the current lock doesn't intersect our region, therefore none of + the locks in the list will} + else begin + btfLockMgrIsLockReq := true; + aOffset1 := aReqOffset; + aLength1 := aReqLength; + Exit; + end; + + {if we reach this point we know that at least one existing lock + intersects our region, and we know the total number that do; + identify at most two sub-locks required (again, to repeat, + analysis of B-Tree Filer's locking behaviour has shown that at + most two sub-locks would be required)} + CheckOffset := aReqOffset; + SubLockToUse := 1; + for Inx := LockInx to pred(LockInx + LockCount) do begin + with blaLocks[Inx] do begin + if (CheckOffset < bliOffset) then begin + btfLockMgrIsLockReq := true; + if (SubLockToUse = 1) then begin + aOffset1 := CheckOffset; + aLength1 := bliOffset - CheckOffset; + end + else begin + aOffset2 := CheckOffset; + aLength2 := bliOffset - CheckOffset; + end; + inc(SubLockToUse); + if (SubLockToUse > 2) then + Exit; + end; + CheckOffset := bliOffset + bliLength; + end; + end; + if (CheckOffset < (aReqOffset + aReqLength)) then begin + btfLockMgrIsLockReq := true; + with blaLocks[pred(LockInx + LockCount)] do begin + if (SubLockToUse = 1) then begin + aOffset1 := CheckOffset; + aLength1 := aReqOffset + aReqLength - CheckOffset; + end + else begin + aOffset2 := CheckOffset; + aLength2 := aReqOffset + aReqLength - CheckOffset; + end; + end; + end; + end; +end; +{--------} +procedure btfLockMgrCreate; +begin + btfLockMgrError := btferrLockMgrSuccess; + btfFileLocks := nil; +end; +{--------} +procedure btfLockMgrDestroy; +var + FileInx : integer; +begin + btfLockMgrError := btferrLockMgrSuccess; + if (btfFileLocks <> nil) then begin + with btfFileLocks^ do begin + for FileInx := pred(bfaCount) downto 0 do + btfLockMgrRemoveFileItem(btfFileLocks, FileInx); + end; + FreeMem(btfFileLocks, + btfLockMgrCalcFileArraySize(btfFileLocks^.bfaMaxCount)); + btfFileLocks := nil; + end; +end; +{====================================================================} + diff --git a/src/wc_sdk/bufrecio.pas b/src/wc_sdk/bufrecio.pas new file mode 100644 index 0000000..c1037b0 --- /dev/null +++ b/src/wc_sdk/bufrecio.pas @@ -0,0 +1,640 @@ +{********************************************************************} +{* BUFRECIO.PAS - Buffered record I/O *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + + +Unit BufRecIO; {!!.50} + +Interface + +Uses + BTBase, + BTIsBase, + Filer, {!!.TP} + VRec; {!!.TP} + + + Procedure CreateRecBuffers ( ReadDatSLen : Word; + AddIFBPtr : IsamFileBlockPtr ); + {-Allocates memory (if available) for the buffers and initializes + private data} + + Procedure DoneRecBuffers; + {-Flushes all write buffered data to disk and deallocates memory} + + Function DecreaseBufferMem : Boolean; + {-Returns True, if memory consumption could be decreased} + + Procedure BufGetBlock ( Var F : IsamFile; Ref, Len : LongInt; Var Dest ); + {-Acts like IsamGetBlock, but can use a buffer} + + Procedure BufAddRec ( IFBPtr : IsamFileBlockPtr; + Var Source ); + {-Acts like BTAddRec, but can use a buffer and doesn't return a + reference} + + Procedure BufGetVariableRecRebuilt ( Var F : IsamFile; + DatSLen : Word; + Var RefNr : LongInt; + DestPtr : Pointer; + DestSize : Word; + Var RecRead : Boolean; + Var Len : Word ); + {-Reads the next (following to RefNr) variable record into the buffer + pointed to by DestPtr; if an error 10070 or 10415 occurs, RefNr is set + appropriately to read the next record; other errors mean abort + reading; if no error occurs and Len returnes 0, there is no more + record to read; if no error occurs and RecRead contains False, then + the buffer was not large enough to hold the record; in this case Len + contains the needed buffer size} + + Procedure BufAddVariableRecRebuilt ( IFBPtr : IsamFileBlockPtr; + SourcePtr : Pointer; + Len : Word ); + {-Acts like BTAddVariableRec, but can use a buffer and doesn't return a + reference} + + Procedure MarkReadBufRecDeleted ( Ref : LongInt ); + {-Marks the reference Ref as deleted, if it's present in the buffer} + + Procedure RewindReadBuffer; + {-Forces the read buffer to start at 1} + +Implementation + + Const + MaxBufferedRecLen = 16384; + MaxBufferSize = 32768; + MinRecsInBuffer = 2; + + type + PioBuffer = ^TioBuffer; + TioBuffer = array [0..MaxBufferSize-1] of byte; + + Type + ReadBufferDescr = packed Record + DatSLen : Word; + BufPtr : PioBuffer; + BufSize : Word; + LogBufSize : Word; + {-Number of records that can be stored in the buffer} + LogBufStart : LongInt; + {-The reference belonging to the first record in the buffer} + LogBufEnd : Word; + {-The number (zero based) of the first not filled record in the + buffer; if LogBufEnd = LogBufSize, the buffer is full; + if LogBufEnd = 0, the buffer is empty} + {-LogBufStart + LogBufEnd is the reference of the first record + not present in the buffer} + End; + + AddBufferDescr = packed Record + IFBPtr : IsamFileBlockPtr; + {-Used to store header information} + DatSLen : Word; + BufPtr : PioBuffer; + BufSize : Word; + LogBufSize : Word; + {-Number of records that can be stored in the buffer} + LogBufStart : LongInt; + {-The reference belonging to the first record in the buffer} + LogBufPos : Word; + {-The number (zero based) of the next free record in the buffer; + if LogBufPos = LogBufSize, the buffer is full; + if LogBufPos = 0, the buffer is empty} + End; + + Const + ReadBufDescrPtr : ^ReadBufferDescr = Nil; + AddBufDescrPtr : ^AddBufferDescr = Nil; + + + Procedure FlushAddBuffer; + + Type + PLongInt = ^LongInt; + + Var + LPtr : PLongInt; + + Begin + If AddBufDescrPtr^.LogBufPos > 0 Then Begin + IsamPutBlock ( AddBufDescrPtr^.IFBPtr^.DatF, + AddBufDescrPtr^.LogBufStart * AddBufDescrPtr^.DatSLen, + AddBufDescrPtr^.DatSLen * AddBufDescrPtr^.LogBufPos, + AddBufDescrPtr^.BufPtr^ ); + If IsamOK Then Begin + LPtr := IsamGetNumRecAddress ( AddBufDescrPtr^.IFBPtr ); + If Not IsamOK Then Exit; + LPtr^:= LPtr^ + AddBufDescrPtr^.LogBufPos; + AddBufDescrPtr^.LogBufStart := AddBufDescrPtr^.LogBufStart + + AddBufDescrPtr^.LogBufPos; + AddBufDescrPtr^.LogBufPos := 0; + End; + End; + End; + + + function GetBuffer(var BufPtr : PioBuffer; AddDatSLen : longint) : integer; + {!!.52 new} + var + i : integer; + begin + i := MaxBufferSize div AddDatSLen; + repeat + if IsamGetMem(BufPtr, (i * AddDatSLen)) then + begin + GetBuffer := i; + Exit; + end; + dec(i); + until (i < MinRecsInBuffer); + GetBuffer := 0; + end; + + + Procedure CreateRecBuffers ( ReadDatSLen : Word; + AddIFBPtr : IsamFileBlockPtr ); + {!!.52 rewritten} + Var + AddDatSLen : LongInt; + NrRecs : Word; + + begin + if AddIFBPtr <> Nil then + begin + AddDatSLen := BTDatRecordSize ( AddIFBPtr ); + if IsamOK and (AddDatSLen <= MaxBufferedRecLen) and + (AddDatSLen > 0) and (BTFileLen(AddIFBPtr) = 1) then + begin + if IsamGetMem(AddBufDescrPtr, sizeof(AddBufferDescr)) then + begin + NrRecs := GetBuffer(AddBufDescrPtr^.BufPtr, AddDatSLen); + if (NrRecs <> 0) then + with AddBufDescrPtr^ do + begin + BufSize := NrRecs * AddDatSLen; + IFBPtr := AddIFBPtr; + DatSLen := AddDatSLen; + LogBufSize := NrRecs; + LogBufStart := 1; + LogBufPos := 0; + end + else + begin + FreeMem(AddBufDescrPtr, sizeof(AddBufferDescr)); + AddBufDescrPtr := nil; + end; + end; + end; + end; + + if (ReadDatSLen > 0) and (ReadDatSLen <= MaxBufferedRecLen) then + begin + if IsamGetMem(ReadBufDescrPtr, sizeof(ReadBufferDescr)) then + begin + NrRecs := GetBuffer(ReadBufDescrPtr^.BufPtr, ReadDatSLen); + if (NrRecs <> 0) then + with ReadBufDescrPtr^ do + begin + BufSize := NrRecs * ReadDatSLen; + DatSLen := ReadDatSLen; + LogBufSize := NrRecs; + LogBufStart := 1; + LogBufEnd := 0; + end + else + begin + FreeMem(ReadBufDescrPtr, sizeof(ReadBufferDescr)); + ReadBufDescrPtr := Nil; + end; + end; + end; + end; + + + Procedure DoneRecBuffers; + + Begin + IsamClearOK; + If ReadBufDescrPtr <> Nil Then Begin + FreeMem ( ReadBufDescrPtr^.BufPtr, ReadBufDescrPtr^.BufSize ); + FreeMem ( ReadBufDescrPtr, SizeOf (ReadBufferDescr) ); + ReadBufDescrPtr := Nil; + End; + If AddBufDescrPtr <> Nil Then Begin + FlushAddBuffer; + FreeMem ( AddBufDescrPtr^.BufPtr, AddBufDescrPtr^.BufSize ); + FreeMem ( AddBufDescrPtr, SizeOf (AddBufferDescr) ); + AddBufDescrPtr := Nil; + End; + End; + + + Function DecreaseBufferMem : Boolean; {!!.52 rewritten} + + Const + MinDecrease = 1024; + + Var + NrRecs : Word; + + Begin + DecreaseBufferMem := True; + IsamClearOK; + If ReadBufDescrPtr <> Nil Then Begin + NrRecs := Succ (Pred (MinDecrease) Div ReadBufDescrPtr^.DatSLen); + {-Number of records to decrease} + If (LongInt (ReadBufDescrPtr^.LogBufSize) - NrRecs) + * ReadBufDescrPtr^.DatSLen < MinDecrease Then Begin + {-Too less buffer left} + NrRecs := ReadBufDescrPtr^.LogBufSize; + End; + NrRecs := ReadBufDescrPtr^.LogBufSize - NrRecs; + {-Number of records to newly allocate} + If NrRecs < MinRecsInBuffer Then NrRecs := 0; + FreeMem ( ReadBufDescrPtr^.BufPtr, ReadBufDescrPtr^.BufSize ); + if (NrRecs > 0) Then + with ReadBufDescrPtr^ do + begin + Inc(LogBufStart, Succ(LogBufSize - NrRecs)); + {-Ensure we will not loose contact} + BufSize := NrRecs * DatSLen; + if IsamGetMem(BufPtr, BufSize) then + begin + LogBufSize := NrRecs; + LogBufEnd := 0; + end + else + NrRecs := 0; + end; + if (NrRecs <= 0) then + begin + FreeMem ( ReadBufDescrPtr, SizeOf (ReadBufferDescr) ); + ReadBufDescrPtr := Nil; + end; + End Else Begin + If AddBufDescrPtr <> Nil Then Begin + FlushAddBuffer; + If Not IsamOK Then Exit; + NrRecs := Succ (Pred (MinDecrease) Div AddBufDescrPtr^.DatSLen); + {-Number of records to decrease} + If (LongInt (AddBufDescrPtr^.LogBufSize) - NrRecs) + * AddBufDescrPtr^.DatSLen < MinDecrease Then Begin + {-Too less buffer left} + NrRecs := AddBufDescrPtr^.LogBufSize; + End; + NrRecs := AddBufDescrPtr^.LogBufSize - NrRecs; + {-Number of records to newly allocate} + If NrRecs < MinRecsInBuffer Then NrRecs := 0; + FreeMem ( AddBufDescrPtr^.BufPtr, AddBufDescrPtr^.BufSize ); + if (NrRecs > 0) then + with AddBufDescrPtr^ do + begin + BufSize := NrRecs * DatSLen; + if IsamGetMem(BufPtr, BufSize) then + LogBufSize := NrRecs + else + NrRecs := 0; + end; + if (NrRecs <= 0) then + begin + FreeMem(AddBufDescrPtr, sizeof(AddBufferDescr)); + AddBufDescrPtr := Nil; + end; + End Else Begin + DecreaseBufferMem := False; + End; + End; + End; + + + Procedure BufGetBlock ( Var F : IsamFile; Ref, Len : LongInt; Var Dest ); + {!!.51 rewritten} + Var + BytesRead : longint; + ReqLen, + ReadLen : longint; + ReadBuffered : Boolean; + + Begin + IsamClearOK; + ReadBuffered := ReadBufDescrPtr <> Nil; + If ReadBuffered Then Begin + {--Do we have it in the buffer?} + If ReadBufDescrPtr^.LogBufStart * ReadBufDescrPtr^.DatSLen <= Ref + Then Begin + {-May be there or loadable} + If (ReadBufDescrPtr^.LogBufStart + ReadBufDescrPtr^.LogBufEnd) + * ReadBufDescrPtr^.DatSLen > Ref Then Begin + {-The start of the required block is in the buffer} + If (ReadBufDescrPtr^.LogBufStart + ReadBufDescrPtr^.LogBufEnd) + * ReadBufDescrPtr^.DatSLen <= (Ref + Len) Then Begin + {-The end of the required block is not in the buffer; so we + cannot have this part and the needed following part in the + buffer at the same time; this does normally not occure; + else everything is ok} + ReadBuffered := False; + End; + End Else Begin + {-The start of the required block is not in the buffer} + {--Will the start of the required block be in the next buffer?} + If (ReadBufDescrPtr^.LogBufStart + ReadBufDescrPtr^.LogBufEnd + + ReadBufDescrPtr^.LogBufSize) + * ReadBufDescrPtr^.DatSLen <= Ref Then Begin + {-No, so read from disk without forwarding the buffer} + ReadBuffered := False; + End Else Begin + {-Yes, so forward the buffer} + IsamLongSeek ( F, (ReadBufDescrPtr^.LogBufStart + + ReadBufDescrPtr^.LogBufEnd) * ReadBufDescrPtr^.DatSLen ); + If Not IsamOK Then Exit; + ReqLen := ReadBufDescrPtr^.BufSize; + IsamBlockReadRetLen ( F, ReadBufDescrPtr^.BufPtr^, ReqLen, + BytesRead ); + If Not IsamOK Then Exit; + Inc (ReadBufDescrPtr^.LogBufStart, ReadBufDescrPtr^.LogBufEnd); + ReadBufDescrPtr^.LogBufEnd := BytesRead + Div ReadBufDescrPtr^.DatSLen; + If (ReadBufDescrPtr^.LogBufStart + ReadBufDescrPtr^.LogBufEnd) + * ReadBufDescrPtr^.DatSLen < (Ref + Len) Then Begin + {-The end of the required block is not in the buffer; so we + failed to fill the buffer with the required data; this does + normally only occure at the end of the file; so let the + original reading routine set any errors; + else everything is ok} + ReadBuffered := False; + End; + End; + End; + End Else Begin + {-Since we do not fill the buffer by reading backward, + read the record from disk} + ReadBuffered := False; + End; + End; + If ReadBuffered Then + with ReadBufDescrPtr^ do + Move(BufPtr^[Ref - LogBufStart * DatSLen], Dest, Len) + Else + IsamGetBlock ( F, Ref, Len, Dest ); + End; + + + Procedure BufAddRec ( IFBPtr : IsamFileBlockPtr; + Var Source ); + + Var + DummyRef : LongInt; + + Begin + If AddBufDescrPtr <> Nil Then Begin + IsamClearOK; + If AddBufDescrPtr^.LogBufPos = AddBufDescrPtr^.LogBufSize Then Begin + {-Buffer is full} + FlushAddBuffer; + If Not IsamOK Then Exit; + End; + with AddBufDescrPtr^ do + begin + Move(Source, + BufPtr^[LogBufPos * DatSLen], + DatSLen); + Inc(LogBufPos); + end; + End Else Begin + IsamAddRec ( IFBPtr, DummyRef, Source ); + End; + End; + + + Procedure BufGetVariableRecRebuilt ( Var F : IsamFile; + DatSLen : Word; + Var RefNr : LongInt; + DestPtr : Pointer; + DestSize : Word; + Var RecRead : Boolean; + Var Len : Word ); + + + Function FindNextValidRecStart ( Var NRef : LongInt ) : Boolean; + + Var + DelMark : LongInt; + + Begin + FindNextValidRecStart := False; + Repeat + Inc (NRef); + BufGetBlock ( F, NRef * DatSLen, SizeOf (LongInt), DelMark ); + If Not IsamOK Then Begin + If IsamError = 10070 Then IsamClearOK; + Exit; + End; + Until DelMark = 0; + FindNextValidRecStart := True; + End; + + + Var + Pos, + NrOfRecs, + IVRBPos, + MaxRecs : Word; + CPtr : ^Word; + LPtr : ^LongInt; + TRef : LongInt; + + Begin + IsamClearOK; + RecRead := False; + + TRef := RefNr; + If Not FindNextValidRecStart ( TRef ) Then Begin + {-No further data or error} + Len := 0; + Exit; + End; + + RecRead := True; + + RefNr := Pred (TRef); + {-In case we fail because of too less memory, the next trial starts + at the best position} + + CPtr := @IVRBPtr^ [DatSLen-6]; + LPtr := @IVRBPtr^ [DatSLen-4]; + MaxRecs := (MaxVariableRecLengthM1 - (DatSLen - 6)) + Div (DatSLen - 6) + 2; + NrOfRecs := 0; + Pos := 0; + LPtr^ := TRef; + IVRBPos := 0; + + Repeat + BufGetBlock ( F, LPtr^ * DatSLen, DatSLen, IVRBPtr^ ); + If Not IsamOK Then Begin + If IsamError = 10070 Then RefNr := TRef; + Exit; + End; + If (LongInt (Pos) + CPtr^) > DestSize Then RecRead := False; + If RecRead Then Move ( IVRBPtr^ [IVRBPos], + PIsamVRecBuf (DestPtr)^ [Pos], CPtr^ ); + If Pos = 0 Then Inc (IVRBPos); + Inc (Pos, CPtr^); + Inc (NrOfRecs); + Until (LPtr^ = 0) Or (NrOfRecs > MaxRecs); + + If (NrOfRecs > MaxRecs) Or (Pos = 0) Then Begin + IsamOK := False; + IsamError := 10415; + RefNr := TRef; + Exit; + End; + Len := Pos; + If RecRead Then RefNr := TRef; + End; + + + Procedure BufAddVariableRecRebuilt ( IFBPtr : IsamFileBlockPtr; + SourcePtr : Pointer; + Len : Word ); + + + Function GetNextNewLogRecNr : LongInt; + + Begin + If AddBufDescrPtr <> Nil Then Begin + GetNextNewLogRecNr := AddBufDescrPtr^.LogBufStart + + AddBufDescrPtr^.LogBufPos; + End Else Begin + GetNextNewLogRecNr := BTFileLen ( IFBPtr ); + End; + End; + + + Function GetDatSLen : Word; + + Begin + If AddBufDescrPtr <> Nil Then Begin + GetDatSLen := AddBufDescrPtr^.DatSLen; + End Else Begin + GetDatSLen := BTDatRecordSize ( IFBPtr ); + End; + End; + + + Var + NextLogRec : LongInt; + Pos, + CurCont, + IVRBPos, + AddDatSLen : Word; + CPtr : ^Word; + LPtr : ^LongInt; + + Begin + IsamClearOK; + + AddDatSLen := GetDatSLen; + If Not IsamOK Then Exit; + + CPtr := @IVRBPtr^ [AddDatSLen-6]; + LPtr := @IVRBPtr^ [AddDatSLen-4]; + Pos := 0; + IVRBPos := 0; + + While Len > 0 Do Begin + If Pos = 0 Then Begin + CurCont := AddDatSLen - 6; + End Else Begin + CurCont := AddDatSLen - 7; + IVRBPtr^ [0] := 1; + End; + If CurCont > Len Then CurCont := Len; + Move ( PIsamVRecBuf (SourcePtr)^ [Pos], IVRBPtr^ [IVRBPos], CurCont ); + CPtr^ := CurCont; + Dec (Len, CurCont); + If Len = 0 Then Begin + LPtr^ := 0; + End Else Begin + LPtr^ := Succ (GetNextNewLogRecNr); + If Not IsamOK Then Exit; + End; + + BufAddRec ( IFBPtr, IVRBPtr^ ); + If Not IsamOK Then Exit; + + If Pos = 0 Then Inc (IVRBPos); + Inc (Pos, CurCont); + End; + End; + + + Procedure MarkReadBufRecDeleted ( Ref : LongInt ); + + Type + PByte = ^Byte; + + Begin + If ReadBufDescrPtr <> Nil Then Begin + If (Ref >= ReadBufDescrPtr^.LogBufStart) + And (Ref < (ReadBufDescrPtr^.LogBufStart + + ReadBufDescrPtr^.LogBufEnd)) Then Begin + {-The record is buffered} + with ReadBufDescrPtr^ do + BufPtr^[(Ref - LogBufStart) * DatSLen] := 1; + End; + End; + End; + + + Procedure RewindReadBuffer; + + Begin + If ReadBufDescrPtr <> Nil Then Begin + If ReadBufDescrPtr^.LogBufStart <> 1 Then Begin + ReadBufDescrPtr^.LogBufStart := 1; + ReadBufDescrPtr^.LogBufEnd := 0; + End + End; + End; + + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. \ No newline at end of file diff --git a/src/wc_sdk/carrconv.pas b/src/wc_sdk/carrconv.pas new file mode 100644 index 0000000..d899817 --- /dev/null +++ b/src/wc_sdk/carrconv.pas @@ -0,0 +1,1232 @@ +{********************************************************************} +{* CARRCONV.PAS - character array conversion *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF UseSymFlex} + {$I dddefine.inc} +{$ENDIF} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} +{$N+} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +Unit CArrConv; + +Interface +{$IFDEF SymFlexGE20} +Uses + FLibSupp; +{$ELSE} + {$IFDEF Windows} +Uses + {$IFDEF VER80} {!!.51} + SysUtils; {!!.51} + {$ELSE} {!!.51} + Strings; + {$ENDIF} {!!.51} + {$ENDIF} +{$ENDIF} + + + Function Char2Boolean ( Var Value : Boolean; + Chr : Char ) : Integer; + + Function CArr2LBStr ( Var LBStr : String; + CArr : Pointer; + Size : Word ) : Integer; + + Function CArr2AZStr ( AZStr, + CArr : Pointer; + Size : Word ) : Integer; + + Function CArr2Date ( Var TheDate : Longint; + CArr : Pointer ) : Integer; + + Function CArr2Time ( Var TheTime : Longint; + CArr : Pointer ) : Integer; + + Function CArr2Byte ( Var Value : Byte; + CArr : Pointer; + Size : Word ) : Integer; + + Function CArr2ShortInt ( Var Value : Shortint; + CArr : Pointer; + Size : Word ) : Integer; + + Function CArr2Integer ( Var Value : Integer; + CArr : Pointer; + Size : Word ) : Integer; + + Function CArr2LongInt ( Var Value : Longint; + CArr : Pointer; + Size : Word ) : Integer; + + Function CArr2Word ( Var Value : Word; + CArr : Pointer; + Size : Word ) : Integer; + + Function CArr2Single ( Var Value : Single; + CArr : Pointer; + Size : Word ) : Integer; + + Function CArr2Real ( Var Value : Real; + CArr : Pointer; + Size : Word ) : Integer; + + Function CArr2Comp ( Var Value : Comp; + CArr : Pointer; + Size : Word ) : Integer; + + Function CArr2Double ( Var Value : Double; + CArr : Pointer; + Size : Word ) : Integer; + + Function CArr2Extended ( Var Value : Extended; + CArr : Pointer; + Size : Word ) : Integer; + + + Function Date2CArr ( CArr : Pointer; + TheDate : Longint ) : Integer; + + Function Time2CArr ( CArr : Pointer; + TheTime : Longint ) : Integer; + + Function Boolean2Char ( Var Chr : Char; + Value : Boolean ) : Integer; + + Function LBStr2CArr ( CArr : Pointer; + Str : String; + Size : Word ) : Integer; + + Function AZStr2CArr ( CArr, + Str : Pointer; + Size : Word ) : Integer; + + Function ShortInt2CArr ( CArr : Pointer; + Value : Shortint; + Width : Word ) : Integer; + + Function Byte2CArr ( CArr : Pointer; + Value : Byte; + Width : Integer ) : Integer; + + Function Integer2CArr ( CArr : Pointer; + Value : Integer; + Width : Integer ) : Integer; + + Function Word2CArr ( CArr : Pointer; + Value : Word; + Width : Integer ) : Integer; + + Function LongInt2CArr ( CArr : Pointer; + Value : Longint; + Width : Integer ) : Integer; + + Function Single2CArr ( CArr : Pointer; + Value : Single; + Width : Integer; + Decimals : Integer ) : Integer; + + Function Real2CArr ( CArr : Pointer; + Value : Real; + Width : Integer; + Decimals : Integer ) : Integer; + + Function Double2CArr ( CArr : Pointer; + Value : Double; + Width : Integer; + Decimals : Integer ) : Integer; + + Function Comp2CArr ( CArr : Pointer; + Value : Comp; + Width : Integer ) : Integer; + + Function Extended2CArr ( CArr : Pointer; + Value : Extended; + Width : Integer; + Decimals : Integer ) : Integer; + + +Implementation {=========================================================} + + +{$IFNDEF SymFlexGE20} + Const + Offset1900 : Word = 20; + {-Must be in range 0..99; + dates less than 100 are interpreted to be in the 20th century when + they are greater than Offset1900, else in the 21st century} + BadDate = $FFFFFFFF; + BadTime = $FFFFFFFF; + MaxDateVal = 876581; {31.12.3999} + + {$IFNDEF Windows} + Type + PChar = ^Char; + {$ENDIF} + + Type + CharArr = Array [0 .. $FFFE] Of Char; + PCharArr = ^CharArr; + Date = LongInt; + Time = LongInt; +{$ENDIF} + + +{$IFNDEF SymFlexGE20} + Function Trim ( S : String ) : String; + + Var + I : Word; + SLen : Byte Absolute S; + OK : Boolean; + + Begin + While (SLen > 0) And (S [SLen] <= ' ') Do Begin + Dec (SLen); + End; + + I := 1; + OK := True; + While (I <= SLen) And OK Do Begin + If S [I] <= ' ' Then Begin + Inc (I); + End Else Begin + OK := False; + End; + End; + + If I > 1 Then Delete (S, 1, Pred (I)); + + Trim := S; + End; + + + Function GetAZSLength ( AZSPtr : PChar ) : Word; + + Var + L : Word; + + Begin + {$IFDEF Windows} + GetAZSLength := StrLen (AZSPtr); + {$ELSE} + Inline ( + $FC / { Cld } + $C4 / $BE / AZSPtr / { Les DI, AZSPtr [BP] } + $B9 / $FF / $FF / { Mov CX, $FFFF } + $31 / $C0 / { Xor AX, AX } + $F2 / { Repne } + $AE / { Scasb } + $B8 / $FE / $FF / { Mov AX, $FFFE } + $29 / $C8 / { Sub AX, CX } + $89 / $86 / L { Mov [BP+Ofs(L)], AX } + ); + GetAZSLength := L; + {$ENDIF} + End; +{$ENDIF} + + + Procedure ExpandYear ( Var Year : Word ); + + Begin + If Year < 100 Then Begin + If Year < Offset1900 Then Begin + Inc (Year, 2000); + End Else Begin + Inc (Year, 1900); + End; + End; + End; + + +{$IFNDEF SymFlexGE20} + Function IsLeapYear ( Year : Word ) : Boolean; + + Begin + IsLeapYear := (Year Mod 4 = 0) And (Year Mod 4000 <> 0) + And ((Year Mod 100 <> 0) Or (Year Mod 400 = 0)); + End; + + + Function DaysInMonth ( Month, Year : Word ) : Word; + + Begin + Case Month Of + 1, 3, 5, 7, 8, 10, 12 : + DaysInMonth := 31; + 4, 6, 9, 11 : + DaysInMonth := 30; + 2 : Begin + ExpandYear ( Year ); + DaysInMonth := 28 + Ord (IsLeapYear ( Year )); + End; + Else DaysInMonth := 0; + End; {Case} + End; + + + Function SplitDateIsOk ( Day, Month, Year : Word ) : Boolean; + + Begin + SplitDateIsOk := False; + ExpandYear ( Year ); + If (Day = 0) Or (Year < 1600) Or (Year > 3999) Then Exit; + Case Month Of + 1..12 : Begin + SplitDateIsOk := Day <= DaysInMonth ( Month, Year ); + End; + End; {Case} + End; + + + Function DMYToDateVal ( Day, Month, Year : Word ) : Date; + + Var + I : Word; + NrOfDays : LongInt; + + Begin + ExpandYear ( Year ); + If Not SplitDateIsOk ( Day, Month, Year ) Then Begin + DMYtoDateVal := BadDate; + Exit; + End; + + NrOfDays := (LongInt (Year) - 1600) * 365 + + (LongInt (Year) - 1597) Div 4 + - (LongInt (Year) - 1601) Div 100 + + (LongInt (Year) - 1601) Div 400; + + For I := 1 To Pred (Month) Do Begin + NrOfDays := NrOfDays + DaysInMonth ( I, Year ); + End; + + DMYToDateVal := NrOfDays + Pred (Day); + End; + + + Function DateIsOk ( TheDate : Date ) : Boolean; + + Begin + DateIsOk := (TheDate >= 0) And (TheDate <= MaxDateVal); + End; + + + Function DaysInYear ( Year : Word ) : Word; + + Begin + DaysInYear := 365 + Ord (IsLeapYear ( Year )); + End; + + + Procedure DateValToDMY ( TheDate : Date; + Var Day, + Month, + Year : Word ); + + Var + RemainingDays : LongInt; + + Begin + If Not DateIsOk ( TheDate ) Then Begin + Day := 0; + Month := 0; + Year := 0; + Exit; + End; + {--TheDate div number of days in a 4 years block multiplied by 4 is + used as an estimate for the year which may be too small} + Year := Word (TheDate Div 1461 * 4) + 1600; + RemainingDays := TheDate - DMYToDateVal ( 1, 1, Year ); + + While RemainingDays >= DaysInYear ( Year ) Do Begin + RemainingDays := RemainingDays - DaysInYear ( Year ); + Inc (Year); + End; + + Month := 1; + While RemainingDays >= DaysInMonth ( Month, Year ) Do Begin + RemainingDays := RemainingDays - DaysInMonth ( Month, Year ); + Inc (Month); + End; + + Day := Succ (Word (RemainingDays)); + End; + + + Function SplitTimeIsOk ( Hour, Min, Sec : Word ) : Boolean; + + Begin + SplitTimeIsOk := (Hour < 24) And (Min < 60) And (Sec < 60); + End; + + + Function HMSToTimeVal ( Hour, Min, Sec : Word ) : Time; + + Begin + If SplitTimeIsOk ( Hour, Min, Sec ) Then Begin + HMSToTimeVal := (LongInt (Hour) * 3600) + (LongInt (Min) * 60) + Sec; + End Else Begin + HMSToTimeVal := BadTime; + End; + End; + + + Function TimeIsOk ( TheTime : Time ) : Boolean; + + Begin + TimeIsOk := (TheTime >= 0) And (TheTime < 86400); + End; + + + Procedure TimeValToHMS ( TheTime : Time; Var Hour, Min, Sec : Word ); + + Begin + If Not TimeIsOk ( TheTime ) Then Begin + Hour := 0; + Min := 0; + Sec := 0; + Exit; + End; + Hour := TheTime Div 3600; + TheTime := TheTime Mod 3600; + Min := TheTime Div 60; + TheTime := TheTime Mod 60; + Sec := TheTime; + End; +{$ENDIF} + + + Function LBStr2CArr ( CArr : Pointer; + Str : String; + Size : Word ) : Integer; + + Var + Len : Integer; + + Begin + Len := Length ( Str ); + If Len > Size Then + Len := Integer ( Size ); + Move ( Str [1], CArr^, Len); + If Len < Size Then + FillChar ( PCharArr ( CArr )^ [Len], Size - Len, #32 ); + LBStr2CArr := 0; + End; + + + Function AZStr2CArr ( CArr, + Str : Pointer; + Size : Word ) : Integer; + + Var + Len : Word; + + Begin + Len := GetAZSLength ( Str ); + If Len > Size Then + Len := Size; + Move ( Str^, CArr^, Len ); + If Len < Size Then + FillChar ( PCharArr ( CArr )^ [Len], Size - Len, #32 ); + AZStr2CArr := 0; + End; + + + Function CArr2LBStr ( Var LBStr : String; + CArr : Pointer; + Size : Word ) : Integer; + + Begin + CArr2LBStr := -1; + If Size > 255 Then Exit; + Move ( CArr^, LBStr [1], Size ); + LBStr [0] := Char ( Size ); + CArr2LBStr := 0; + End; + + + Function CArr2AZStr ( AZStr, + CArr : Pointer; + Size : Word ) : Integer; + + Begin + Move ( CArr^, AZStr^, Size ); + PCharArr ( AZStr )^ [Size] := #0; + CArr2AZStr := 0; + End; + + + Function Char2Boolean ( Var Value : Boolean; + Chr : Char ) : Integer; + Begin + Char2Boolean := 0; + Case Upcase ( Chr ) Of + 'T', 'Y', 'J': Value := True; + 'F', 'N': Value := False; + Else Begin + Value := False; + Char2Boolean := -1; + End; + End; + End; + + + Function Str2DMY ( Str : String; + Var Day, + Month, + Year : Word ) : Boolean; + + Var + Res : Integer; + TStr : String; + + Begin + Str2DMY := False; + + If Length ( Str ) < 8 Then Exit; + + TStr := Str [1] + Str [2] + Str [3] + Str [4]; + Val ( TStr, Year, Res ); + If Res <> 0 Then Exit; + + TStr := Str [5] + Str [6]; + Val ( TStr, Month, Res ); + If Res <> 0 Then Exit; + + TStr := Str [7] + Str [8]; + Val ( TStr, Day, Res ); + If Res <> 0 Then Exit; + + Str2DMY := True; + End; + + + Function CArr2Date ( Var TheDate : Longint; + CArr : Pointer ) : Integer; + + Var + TStr : String; + Year, Month, Day : Word; + + Begin + CArr2Date := -1; + TheDate := 0; + + If CArr2LBStr ( TStr, CArr, 8 ) <> 0 Then Exit; + TStr := Trim ( TStr ); + If TStr = '' Then Begin + CArr2Date := 0; + Exit; + End; + If Not Str2DMY ( TStr, Day, Month, Year ) Then Exit; + TheDate := DMYToDateVal ( Day, Month, Year ); + If TheDate = BadDate Then Exit; + + CArr2Date := 0; + End; + + + Function TimeStr2HMS ( Var Str : String; + Var Hour, + Min, + Sec : Integer ) : Boolean; + + Var + Res : Integer; + TStr : String; + + Begin + TimeStr2HMS := False; + + If Length ( Str ) < 8 Then Exit; + + TStr := Str [1] + Str [2]; + Val ( TStr, Hour, Res ); + If Res <> 0 Then Exit; + + TStr := Str [4] + Str [5]; + Val ( TStr, Min, Res ); + If Res <> 0 Then Exit; + + TStr := Str [7] + Str [8]; + Val ( TStr, Sec, Res ); + If Res <> 0 Then Exit; + + TimeStr2HMS := True; + End; + + + Function CArr2Time ( Var TheTime : Longint; + CArr : Pointer ) : Integer; + + Var + TStr : String; + Hour, + Min, + Sec : Integer; + + Begin + CArr2Time := -1; + + If CArr2LBStr ( TStr, CArr, 8 ) <> 0 Then Exit; + TStr := Trim ( TStr ); + If TStr = '' Then Begin + TheTime := 0; + CArr2Time := 0; + Exit; + End; + If Not TimeStr2HMS ( TStr, Hour, Min, Sec ) Then Exit; + TheTime := HMSToTimeVal ( Hour, Min, Sec ); + If TheTime = BadTime Then Exit; + + CArr2Time := 0; + End; + + + Function IsNumStr ( Str : String; + MaxLen : Integer; + Signed, + Float, + Empty : Boolean ) : Boolean; + + Var + I : Integer; + CSet : Set Of Char; + + Begin + If Str <> '' Then Begin + IsNumStr := False; + If Length ( Str ) > MaxLen Then Exit; + If Str [1] = '-' Then Begin + If Signed Then Begin + Delete ( Str, 1, 1 ); + End Else Begin + Exit; + End; + End; + CSet := []; + For I := 1 To Length ( Str ) Do + CSet := CSet + [ Str [I] ]; + If Float Then Begin + IsNumStr := CSet <= ['.', '0' .. '9']; + End Else Begin + IsNumStr := CSet <= ['0' .. '9']; + End; + Exit; + End; + IsNumStr := Empty; + End; + + + Function CArr2Byte ( Var Value : Byte; + CArr : Pointer; + Size : Word ) : Integer; + + Var + Res : Integer; + TStr : String; + + Begin + CArr2Byte := -1; + + If CArr2LBStr ( TStr, CArr, Size ) <> 0 Then Exit; + TStr := Trim ( TStr ); + If TStr = '' Then Begin + Value := 0; + CArr2Byte := 0; + Exit; + End; + If Not IsNumStr ( TStr, Size, True, False, True ) Then Exit; + Val ( TStr, Value, Res ); + If Res <> 0 Then Exit; + + CArr2Byte := 0; + End; + + + Function CArr2ShortInt ( Var Value : Shortint; + CArr : Pointer; + Size : Word ) : Integer; + + Var + Res : Integer; + TStr : String; + + Begin + CArr2ShortInt := -1; + + If CArr2LBStr ( TStr, CArr, Size ) <> 0 Then Exit; + TStr := Trim ( TStr ); + If TStr = '' Then Begin + Value := 0; + CArr2ShortInt := 0; + Exit; + End; + If Not IsNumStr ( TStr, Size, True, False, True ) Then Exit; + Val ( TStr, Value, Res ); + If Res <> 0 Then Exit; + + CArr2ShortInt := 0; + End; + + + Function CArr2Integer ( Var Value : Integer; + CArr : Pointer; + Size : Word ) : Integer; + + Var + Res : Integer; + TStr : String; + + Begin + CArr2Integer := -1; + + If CArr2LBStr ( TStr, CArr, Size ) <> 0 Then Exit; + TStr := Trim ( TStr ); + If TStr = '' Then Begin + Value := 0; + CArr2Integer := 0; + Exit; + End; + If Not IsNumStr ( TStr, Size, True, False, True ) Then Exit; + Val ( TStr, Value, Res ); + If Res <> 0 Then Exit; + + CArr2Integer := 0; + End; + + + Function CArr2Word ( Var Value : Word; + CArr : Pointer; + Size : Word ) : Integer; + + Var + Res : Integer; + TStr : String; + + Begin + CArr2Word := -1; + + If CArr2LBStr ( TStr, CArr, Size ) <> 0 Then Exit; + TStr := Trim ( TStr ); + If TStr = '' Then Begin + Value := 0; + CArr2Word := 0; + Exit; + End; + If Not IsNumStr ( TStr, Size, True, False, True ) Then Exit; + Val ( TStr, Value, Res ); + If Res <> 0 Then Exit; + + CArr2Word := 0; + End; + + + Function CArr2LongInt ( Var Value : Longint; + CArr : Pointer; + Size : Word ) : Integer; + + Var + Res : Integer; + TStr : String; + + Begin + CArr2LongInt := -1; + + If CArr2LBStr ( TStr, CArr, Size ) <> 0 Then Exit; + TStr := Trim ( TStr ); + If TStr = '' Then Begin + Value := 0; + CArr2LongInt := 0; + Exit; + End; + If Not IsNumStr ( TStr, Size, True, False, True ) Then Exit; + Val ( TStr, Value, Res ); + If Res <> 0 Then Exit; + + CArr2LongInt := 0; + End; + + + Function CArr2Comp ( Var Value : Comp; + CArr : Pointer; + Size : Word ) : Integer; + + Var + Res : Integer; + TStr : String; + + Begin + CArr2Comp := -1; + + If CArr2LBStr ( TStr, CArr, Size ) <> 0 Then Exit; + TStr := Trim ( TStr ); + If TStr = '' Then Begin + Value := 0.0; + CArr2Comp := 0; + Exit; + End; + If Not IsNumStr ( TStr, Size, True, True, True ) Then Exit; + Val ( TStr, Value, Res ); + If Res <> 0 Then Exit; + + CArr2Comp := 0; + End; + + + Function CArr2Single ( Var Value : Single; + CArr : Pointer; + Size : Word ) : Integer; + + Var + Res : Integer; + TStr : String; + + Begin + CArr2Single := -1; + + If CArr2LBStr ( TStr, CArr, Size ) <> 0 Then Exit; + TStr := Trim ( TStr ); + If TStr = '' Then Begin + Value := 0.0; + CArr2Single := 0; + Exit; + End; + If Not IsNumStr ( TStr, Size, True, True, True ) Then Exit; + Val ( TStr, Value, Res ); + If Res <> 0 Then Exit; + + CArr2Single := 0; + End; + + + Function CArr2Real ( Var Value : Real; + CArr : Pointer; + Size : Word ) : Integer; + + Var + Res : Integer; + TStr : String; + + Begin + CArr2Real := -1; + + If CArr2LBStr ( TStr, CArr, Size ) <> 0 Then Exit; + TStr := Trim ( TStr ); + If TStr = '' Then Begin + Value := 0.0; + CArr2Real := 0; + Exit; + End; + If Not IsNumStr ( TStr, Size, True, True, True ) Then Exit; + Val ( TStr, Value, Res ); + If Res <> 0 Then Exit; + + CArr2Real := 0; + End; + + + Function CArr2Double ( Var Value : Double; + CArr : Pointer; + Size : Word ) : Integer; + + Var + Res : Integer; + TStr : String; + + Begin + CArr2Double := -1; + + If CArr2LBStr ( TStr, CArr, Size ) <> 0 Then Exit; + TStr := Trim ( TStr ); + If TStr = '' Then Begin + Value := 0.0; + CArr2Double := 0; + Exit; + End; + If Not IsNumStr ( TStr, Size, True, True, True ) Then Exit; + Val ( TStr, Value, Res ); + If Res <> 0 Then Exit; + + CArr2Double := 0; + End; + + + Function CArr2Extended ( Var Value : Extended; + CArr : Pointer; + Size : Word ) : Integer; + + Var + Res : Integer; + TStr : String; + + Begin + CArr2Extended := -1; + + If CArr2LBStr ( TStr, CArr, Size ) <> 0 Then Exit; + TStr := Trim ( TStr ); + If TStr = '' Then Begin + Value := 0.0; + CArr2Extended := 0; + Exit; + End; + If Not IsNumStr ( TStr, Size, True, True, True ) Then Exit; + Val ( TStr, Value, Res ); + If Res <> 0 Then Exit; + + CArr2Extended := 0; + End; + + + Function DMY2DateStr ( Var DateStr : String; + Day, + Month, + Year : Word ) : Integer; + + Var + TStr : String; + TempOff1900 : Word; {!!.42} + I : Integer; {!!.42} + + Begin + DMY2DateStr := -1; + + TempOff1900 := Offset1900; {!!.42} + Offset1900 := 0; + ExpandYear ( Year ); + Offset1900 := TempOff1900; {!!.42} + + Str ( Year : 4 , TStr ); + If Length ( TStr ) <> 4 Then Exit; + DateStr := TStr; + Str ( Month : 2, TStr ); + If Length ( TStr ) <> 2 Then Exit; + DateStr := DateStr + TStr; + Str ( Day : 2, TStr ); + If Length ( TStr ) <> 2 Then Exit; + DateStr := DateStr + TStr; + + For I := 1 To Length ( DateStr ) Do Begin {!!.42} + If DateStr [I] = ' ' Then DateStr [I] := '0' {!!.42} + End; {!!.42} + + DMY2DateStr := 0; + End; + + + Function Date2CArr ( CArr : Pointer; + TheDate : Longint ) : Integer; + + Var + TStr : String; + Month, Day, Year : Word; + + Begin + Date2CArr := -1; + + DateValToDMY ( TheDate, Day, Month, Year ); + If DMY2DateStr ( TStr, Day, Month, Year ) <> 0 Then Exit; + If LBStr2CArr ( CArr, TStr, 8 ) <> 0 Then Exit; + + Date2CArr := 0; + End; + + + Function HMS2TimeStr ( Var TimeStr : String; + Hour, + Min, + Sec : Integer ) : Boolean; + + Var + TStr : String; + + Begin + HMS2TimeStr := False; + + Str ( Hour : 2 , TStr ); + If Length ( TStr ) <> 2 Then Exit; + TimeStr := TStr + ':'; + Str ( Min : 2, TStr ); + If Length ( TStr ) <> 2 Then Exit; + TimeStr := TimeStr + TStr + ':'; + Str ( Sec : 2, TStr ); + If Length ( TStr ) <> 2 Then Exit; + TimeStr := TimeStr + TStr; + + HMS2TimeStr := True; + End; + + + Function Time2CArr ( CArr : Pointer; + TheTime : Longint ) : Integer; + + Var + TStr : String; + Hour, + Min, + Sec : Word; + + Begin + Time2CArr := -1; + + If Not TimeIsOk ( TheTime ) Then Exit; + TimeValToHMS ( TheTime, Hour, Min, Sec ); + If Not HMS2TimeStr ( TStr, Hour, Min, Sec ) Then Exit; + + Time2CArr := LBStr2CArr ( CArr, TStr, 8 ); + End; + + + Function Boolean2Char ( Var Chr : Char; Value : Boolean ) : Integer; + + Begin + If Value Then Begin + Chr := 'T'; + End Else Begin + Chr := 'F'; + End; + + Boolean2Char := 0; + End; + + + Function Byte2CArr ( CArr : Pointer; + Value : Byte; + Width : Integer ) : Integer; + + Var + TStr : String; + + Begin + Byte2CArr := -1; + Str ( Value : Width, TStr ); + If Width <> Length ( TStr ) Then Exit; + Move ( TStr [1], CArr^, Width ); + Byte2CArr := 0; + End; + + + Function ShortInt2CArr ( CArr : Pointer; + Value : Shortint; + Width : Word ) : Integer; + + Var + TStr : String; + + Begin + ShortInt2CArr := -1; + Str ( Value : Width, TStr ); + If Width <> Length ( TStr ) Then Exit; + Move ( TStr [1], CArr^, Width ); + ShortInt2CArr := 0; + End; + + + Function Integer2CArr ( CArr : Pointer; + Value : Integer; + Width : Integer ) : Integer; + + Var + TStr : String; + + Begin + Integer2CArr := -1; + Str ( Value : Width, TStr ); + If Width <> Length ( TStr ) Then Exit; + Move ( TStr [1], CArr^, Width ); + Integer2CArr := 0; + End; + + + Function Word2CArr ( CArr : Pointer; + Value : Word; + Width : Integer ) : Integer; + + Var + TStr : String; + + Begin + Word2CArr := -1; + Str ( Value : Width, TStr ); + If Width <> Length ( TStr ) Then Exit; + Move ( TStr [1], CArr^, Width ); + Word2CArr := 0; + End; + + + Function LongInt2CArr ( CArr : Pointer; + Value : Longint; + Width : Integer ) : Integer; + + Var + TStr : String; + + Begin + LongInt2CArr := -1; + Str ( Value : Width, TStr ); + If Width <> Length ( TStr ) Then Exit; + Move ( TStr [1], CArr^, Width ); + LongInt2CArr := 0; + End; + + + Function Comp2CArr ( CArr : Pointer; + Value : Comp; + Width : Integer ) : Integer; + + Var + TStr : String; + + Begin + Comp2CArr := -1; + Str ( Value : Width : 0, TStr ); + If Width <> Length ( TStr ) Then Exit; + Move ( TStr [1], CArr^, Width ); + Comp2CArr := 0; + End; + + + Function Single2CArr ( CArr : Pointer; + Value : Single; + Width : Integer; + Decimals : Integer ) : Integer; + + Var + I : Integer; + TStr : String; + + Begin + Single2CArr := -1; + If Decimals >= 0 Then Begin + Str ( Value : Width : Decimals, TStr ); + End Else Begin + Str ( Value : Width : 0, TStr ); + Decimals := Abs ( Decimals ); + Delete ( TStr, Width - Decimals + 1, Decimals ); + For I := 1 To Decimals Do + Insert ( ' ', TStr, 1 ); + End; + If Width <> Length ( TStr ) Then Exit; + Move ( TStr [1], CArr^, Width ); + Single2CArr := 0; + End; + + + Function Real2CArr ( CArr : Pointer; + Value : Real; + Width : Integer; + Decimals : Integer ) : Integer; + + Var + I : Integer; + TStr : String; + + Begin + Real2CArr := -1; + If Decimals >= 0 Then Begin + Str ( Value : Width : Decimals, TStr ); + End Else Begin + Str ( Value : Width : 0, TStr ); + Decimals := Abs ( Decimals ); + Delete ( TStr, Width - Decimals + 1, Decimals ); + For I := 1 To Decimals Do + Insert ( ' ', TStr, 1 ); + End; + If Width <> Length ( TStr ) Then Exit; + Move ( TStr [1], CArr^, Width ); + Real2CArr := 0; + End; + + + Function Double2CArr ( CArr : Pointer; + Value : Double; + Width : Integer; + Decimals : Integer ) : Integer; + + Var + I : Integer; + TStr : String; + + Begin + Double2CArr := -1; + If Decimals >= 0 Then Begin + Str ( Value : Width : Decimals, TStr ); + End Else Begin + Str ( Value : Width : 0, TStr ); + Decimals := Abs ( Decimals ); + Delete ( TStr, Width - Decimals + 1, Decimals ); + For I := 1 To Decimals Do + Insert ( ' ', TStr, 1 ); + End; + If Width <> Length ( TStr ) Then Exit; + Move ( TStr [1], CArr^, Width ); + Double2CArr := 0; + End; + + + Function Extended2CArr ( CArr : Pointer; + Value : Extended; + Width : Integer; + Decimals : Integer ) : Integer; + + Var + I : Integer; + TStr : String; + + Begin + Extended2CArr := -1; + If Decimals >= 0 Then Begin + Str ( Value : Width : Decimals, TStr ); + End Else Begin + Str ( Value : Width : 0, TStr ); + Decimals := Abs ( Decimals ); + Delete ( TStr, Width - Decimals + 1, Decimals ); + For I := 1 To Decimals Do + Insert ( ' ', TStr, 1 ); + End; + If Width <> Length ( TStr ) Then Exit; + Move ( TStr [1], CArr^, Width ); + Extended2CArr := 0; + End; + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/convert.pas b/src/wc_sdk/convert.pas new file mode 100644 index 0000000..3041bea --- /dev/null +++ b/src/wc_sdk/convert.pas @@ -0,0 +1,112 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +program Convert; +uses + {$IFDEF Windows} + WinCRT, + {$ENDIF} + Filer, Reorg; + +type + DataRecord = {Leave the record name unchanged} + record {!!} + RecDeleted : LongInt; {!! All records should start with this} + LastName : string[20]; {!!} + CustNum : string[10]; {!!} + {...} {!! Other fields follow} + end; +const + DataFileName = 'MYDATA'; {!! Root name for data file. Extension + will always be .DAT} + NrOfKeys = 2; {!! Number of indexes for the data file} +var + IID : IsamIndDescr; {Describes the indexes} + Pages : LongInt; {Number of index pages} + RecordsAdded : LongInt; {Status counter for records added} + RecordsKeyed : LongInt; {Status counter for records keyed} + +{$F+} +function BuildKey(var DatS; KeyNr : Integer) : IsamKeyStr; +begin + if RecordsKeyed = 0 then + WriteLn; + with DataRecord(DatS) do + case KeyNr of {!! Customize this to return each key} + 1 : BuildKey := CustNum; {!!} + 2 : BuildKey := LastName; {!!} + {..} + end; + {Keep status counter running} + inc(RecordsKeyed); + if RecordsKeyed and 15 = 0 then + Write(^M, RecordsKeyed); +end; + +function ChangeDat(var DatSOld; var DatSNew; Len : Word) : Boolean; {!!.22} +begin + if LongInt(DatSOld) = 0 then begin + {Record hasn't been deleted} + ChangeDat := True; + DataRecord(DatSNew) := DataRecord(DatSOld); + {Keep status counter running} + inc(RecordsAdded); + if RecordsAdded and 15 = 0 then + Write(^M, RecordsAdded); + end else + {Record is deleted, don't add it} + ChangeDat := False; +end; +{$F-} + +procedure InitIID; +begin + {!! Specify each index type here} + IID[1].KeyL := 10; {Maximum length of key string} + IID[1].AllowDupK := False; {False for a primary key} + IID[2].KeyL := 20; + IID[2].AllowDupK := True; {True for a secondary key} +end; + +begin + Pages := BTInitIsam(NoNet, 10000, 0); + if not IsamOK then begin + WriteLn('BTInitIsam failed. Not enough memory available'); + Halt; + end; + RecordsAdded := 0; + RecordsKeyed := 0; + InitIID; {!!.01} + ReorgFileBlock(DataFileName, SizeOf(DataRecord), NrOfKeys, + IID, SizeOf(DataRecord), + @BuildKey, @ChangeDat); + WriteLn; + if IsamOK then + WriteLn(RecordsAdded, ' records converted') + else + WriteLn('Convert failed. IsamError = ', IsamError); +end. diff --git a/src/wc_sdk/dbimpexp.pas b/src/wc_sdk/dbimpexp.pas new file mode 100644 index 0000000..61a587c --- /dev/null +++ b/src/wc_sdk/dbimpexp.pas @@ -0,0 +1,1162 @@ +{********************************************************************} +{* DBIMPEXP.PAS - dBASE import/export *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF UseSymFlex} + {$I dddefine.inc} +{$ENDIF} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +Unit + DBImpExp; + +Interface + +Uses +{$IFDEF Windows} + {$IFDEF VER80} {!!.51} + DosSupp, {!!.51} + SysUtils, {!!.51} + {$ELSE} {!!.51} + Strings, + WinDos, + {$ENDIF} {!!.51} +{$ELSE} + Dos, +{$ENDIF} + BTBase, + BTIsBase, + Filer, {!!.TP} +{$IFDEF UseSymFlex} + FLibSupp, + DataDict, +{$ENDIF} + CArrConv; + + +{--Definition of possible languages for error messages of DBaseErrorMessage} + (**************************************************************************) + (*******************) {$DEFINE DBaseGermanMessage} (********************) + (*******************) { $DEFINE DBaseEnglishMessage} (********************) + (**************************************************************************) + {-Adding a space before the $ sign of the DEFINE deactivates the error + messages of this language} + + +Const +{--Interfaced constants} + DBDataExtension : String [3] = 'DBF'; + DBMemoExtension : String [3] = 'DBT'; + DumpExtension : String [3] = 'DMP'; + PasIncExtension : String [3] = 'INC'; + + StartAutoRel : LongInt = 1; {!!.42mod} + + DBFieldNameLen = 10; + AutoRelName = '_AutoRel'; + DelMarkName = '_DelMark'; + +{--FType} + DelMarkFType = #0; + {-Not a dBASE field type, but describes the 1st byte of a dBASE record} + DateFType = 'D'; + CharFType = 'C'; + LogicFType = 'L'; + NumerFType = 'N'; + FloatFType = 'F'; + MemoFType = 'M'; + +{$IFNDEF UseSymFlex} +{--CType} + ReservedCType = 0; + BooleanCType = 1; + CharCType = 2; + ByteCType = 3; + ShortIntCType = 4; + IntegerCType = 5; + WordCType = 6; + LongIntCType = 7; + CompCType = 8; + RealCType = 9; + SingleCType = 10; + DoubleCType = 11; + ExtendedCType = 12; + StringCType = 13; + ArrayCType = 14; +{$ENDIF} {!!.42} +{$IFNDEF SymFlexGE20} {!!.42} + AZStringCType = 15; + DateCType = 16; + TimeCType = 17; +{$ENDIF} + +{--DecideCase} + DCWrite = 0; + DCSkip = 1; + DCAbort = 2; + +{--WorkStatus} + WSInit = 0; + WSWork = 1; + WSExit = 2; + +{--ErrorReaction} + ERAbort = 0; + ERIgnore = 1; + +{--DBaseErrorNr} + DEZERO = 0; {No error} + DEEOF = 9011; {End of file} + DEOOM = 9012; {Out of memory} + DEBV = 9013; {Bad version or not a dBASE III/IV file} + DECMF = 9014; {Corrupted memo file} + DERSTL = 9015; {Record size to large} + DEWCT = 9016; {Wrong CType} + DEEWTD = 9017; {Error writing type definition file} + DEECF = 9018; {Error converting field} + DELHNI = 9019; {List header not initialized or bad part} + DETMF = 9020; {Too many fields} + DEWFT = 9021; {Wrong field type} + DEFWTL = 9022; {Field width too large} + DETMD = 9023; {Too many decimals} + DEFTVC = 9024; {Field type version conflict} + DEARFNA = 9025; {Auto relation field is not allowed here} + DEFCNMF = 9026; {File contains no memo fields} + DEEODF = 9027; {Error opening dump file} + DEEWDF = 9028; {Error writing to dump file} + DEECDF = 9029; {Error closing dump file} + DEPE = 9030; {Programming error} + DEFNAE = 9031; {Field name already exists} + DENFD = 9032; {No field defined} + DELAST = 9033; {Last error const, not an error} + +{--DBaseVersion} + DBVersion3X = $0300; + DBVersion4X = $0400; + +{--Private constants} + DB4MaxFields = 255; + + +{--Interfaced types} +Type + DBaseUsedErrorMessages = ( DBNoMsg, DBGerman, DBEnglish ); + + DBaseFieldName = Array [0 .. DBFieldNameLen] Of Char; + {-dBASE field name} + + DBaseFieldNameStr = String [DBFieldNameLen]; + + DBaseFileName = IsamFileName; + {-DOS file name} + + DBaseVersion = Integer; + + +{--Private types} + DBaseFileField = Record + Name : DBaseFieldName; + FType : Char; + Address : ^Char; + Width, + Decimals : Byte; + Reserved1 : Array [0 .. 1] of Byte; + IDWorkReg : Byte; + Reserved2 : Array [0 .. 1] of Byte; + SetFieldFlag : Byte; + Reserved3 : Array [0 .. 7] of Byte; + End; + PDBaseFileField = ^DBaseFileField; + {-dBASE file descriptor of a field} + + DBaseFileDate = Record + Year, + Month, + Day : Byte; + End; + PDBaseFileDate = ^DBaseFileDate; + {-dBASE date descriptor} + + DBaseFileFieldArray = Array [0 .. DB4MaxFields-1] of DBaseFileField; + PDBaseFileFieldArray = ^DBaseFileFieldArray; + {-An array of dBASE descriptors} + + DBaseFileHeader = Record + DBaseVer : Byte; + LastChange : DBaseFileDate; + NrOfRecs : Longint; + HeaderSize, + RecordSize : Word; + End; + PDBaseFileHeader = ^DBaseFileHeader; + + DBaseFileFullHeader = Record + Part : DBaseFileHeader; + Reserved1 : Array [0 .. 1] Of Char; + TransActionFlag, + EncryptionFlag : Byte; + Reserved2 : Array [0 .. 11] Of Char; + MDXFlag : Byte; + Reserved3 : Array [0 .. 2] Of Char; + End; + PDBaseFileFullHeader = ^DBaseFileFullHeader; + {-dBASE file descriptor of '.DBF' file} + + DBaseMemoHeader = Record + NextFree, + Dummy1 : Longint; + FileName : Array [0 .. 7] Of Char; + Valid : Longint; + BlockSize, + Dummy2 : Word; + End; + PDBaseMemoHeader = ^DBaseMemoHeader; + {-dBASE descriptor of '.DBT' file} + + DBaseMemoRecord = Record + Rec : Array [0 .. 511] Of Char; + End; + PDBaseMemoRecord = ^DBaseMemoRecord; + + DBase4FirstMemoRec = Record + Valid, + Width : Longint; + End; + PDBase4FirstMemoRec = ^DBase4FirstMemoRec; + + DBaseMemoRec = Record + Case Byte Of + 1 : ( Header : DBaseMemoHeader; ); + 2 : ( Rec : DBaseMemoRecord; ); + 3 : ( RecIV : DBase4FirstMemoRec; ); + End; + PDBaseMemoRec = ^DBaseMemoRec; + + IsamField = Record + CType, + BufSize, + Offset : Word; + Width, + Decimals : Integer; + End; + PIsamField = ^IsamField; + + DBaseNormalField = Record + FType : Char; + Width, + Decimals : Byte; + Offset : Word; + End; + PDBaseNormalField = ^DBaseNormalField; + + DBaseAutoRelField = Record + Relation : Longint; + End; + PDBaseAutoRelField = ^DBaseAutoRelField; + + DBaseField = Record + Case NormalContents : Boolean Of + True : ( Normal : DBaseNormalField; ); + False : ( Auto : DBaseAutoRelField; ); + End; + PDBaseField = ^DBaseField; + + PFieldNode = ^FieldNode; + FieldNode = Record + FieldName : DBaseFieldNameStr; + ConvStatus : Integer; + DBFieldPtr : PDBaseField; + BTFieldPtr : PIsamField; + NextPtr : PFieldNode; + End; + + IsamHeader = Record + DatSLen : Word; + FBPtr : IsamFileBlockPtr; + End; + PIsamHeader = ^IsamHeader; + + DBaseMemo = Record + IFile : IsamFile; + Modified : Boolean; + Header : DBaseMemoHeader; + MaxSize : Word; + End; + PDBaseMemo = ^DBaseMemo; + + DBaseHeader = Record + Header : DBaseFileHeader; + DBVer : DBaseVersion; + RefNr : Longint; + Fields : Byte; + IFile : IsamFile; + Modified : Boolean; + MemoPtr : PDBaseMemo; + End; + PDBaseHeader = ^DBaseHeader; + + ListHeader = Record + DBSource : Boolean; + ListPtr : PFieldNode; + DBHeaderPtr : PDBaseHeader; + BTHeaderPtr : PIsamHeader; + End; + +{--Interfaced types} + PListHeader = ^ListHeader; + + DecideCase = Integer; + EnumFct_DecideWrite = Function ( LHPtr : PListHeader; + Errors : Integer; + Var BTBuf, + DBBuf ) : DecideCase; + + WorkStatus = Integer; + IntFct_ReXUser = Function ( Status : WorkStatus; + LHPtr : PListHeader; + ReadRecs, + WriteRecs, + ErrorRecs : Longint; + Var DatSBuf ) : Integer; + + ErrorReaction = Integer; + DBaseErrorNr = Integer; + VoidFct_ErrorHandler = Procedure ( Reaction : ErrorReaction; + IsamError : Integer; + DBaseError : DBaseErrorNr ); + {-Either DBaseError or IsamError is set} + + IntFct_WriteTDef = Function ( LHPtr : PListHeader; + IFName : IsamFileName ) : Integer; + + VoidFct_CharArrConvert = Procedure ( CArrPtr : Pointer; + Len : Word ); + +{--Interfaced routines} + Function DBaseErrorMessage ( ErrorNr : DBaseErrorNr ) : String; + {-Returns an error string} + + Function CreateListHeaderUseDBaseFiles + ( Var LHPtr : PListHeader; + DBFileName : DBaseFileName; + MaxMemoSize : Word ) : Integer; + {-Opens an existing dBASE III/IV file and builds the source (dBASE) + part of the list} + + Function CompleteDBaseList ( LHPtr : PListHeader; + AZStrs, + AutoRel : Boolean ) : Integer; + {-Builds the destination (B-Tree Isam) part of the list} + + Function WriteNoTypeDef ( LHPtr : PListHeader; + IFName : IsamFileName ) : Integer; + {-Passed to DBaseImport to write no type definition} + + Function WritePascalTypeDef ( LHPtr : PListHeader; + IFName : IsamFileName ) : Integer; + {-Passed to DBaseImport to write a Pascal type definition} + + Function DBaseImport ( LHPtr : PListHeader; + IFBName : IsamFileBlockName; + FuncWriteTypeDef : IntFct_WriteTDef; + FuncReXUser : IntFct_ReXUser; + ProcCArrConv : VoidFct_CharArrConvert; + FuncDecideWrite : EnumFct_DecideWrite ) + : Integer; + {-Converts the dBASE file to a B-Tree Isam file} + + Function CloseDBaseFiles ( LHPtr : PListHeader ) : Integer; + {-Closes dBASE file(s)} + + Function CreateListHeaderOpenFileBlock ( BTFileName : IsamFileBlockName ) + : PListHeader; + {-Allocates a ListHeader and returns a pointer to it and opens the + B-Tree Isam Fileblock BTFileName; if an error occurs the error + handler is called and Nil is returned} + + Function AddFieldNode ( Var LHPtr : PListHeader; + Name : DBaseFieldNameStr; + CType, + BufSize, + Offset : Word; + Width, + Decimals : Integer ) : Boolean; + {-Allocates a FieldNode and inserts it at the end of the list LHPtr^; + the B-Tree Isam part is allocated and filled with arguments; + if an error occurs the error handler is called, files are closed, + LHPtr is freed, and False is returned} + + Function CompleteIsamList ( LHPtr : PListHeader; + DBVer : DBaseVersion ) : Integer; + {-Builds the destination (dBASE) part of list} + + Function DBaseExport ( LHPtr : PListHeader; + DBFName : DBaseFileName; + KeyNr : Word; + FuncReXUser : IntFct_ReXUser; + ProcCArrConv : VoidFct_CharArrConvert; + FuncDecideWrite : EnumFct_DecideWrite ) + : Integer; + {-Converts the B-Tree Isam Fileblock to a dBASE file} + + Function CloseIsamFiles ( LHPtr : PListHeader ) : Integer; + {-Closes B-Tree Isam file(s)} + + Procedure FreeListHeader ( Var LHPtr : PListHeader ); + {-Deallocates the LHPtr and its structures} + + Procedure NoErrorHandler ( Reaction : ErrorReaction; + IsamError : Integer; + DBaseError : DBaseErrorNr); + {-Assignable to ProcErrorHandler to install no error handler} + + Function NoReXUser ( Status : WorkStatus; + LHPtr : PListHeader; + ReadRecs, + WriteRecs, + ErrorRecs : Longint; + Var DatSBuf ) : Integer; + {-Should be passed to DBaseImport and DBaseExport in FuncReXUser + if no status infomations of import/export are needed.} + + Procedure NoCArrConv ( CArrPtr : Pointer; + Len : Word ); + + Function StdDecideWrite ( LHPtr : PListHeader; + Errors : Integer; + Var BTBuf, + DBBuf ) : DecideCase; + {-Decides whether the converted record is written or not} + + +{--Interfaced typed constants and variables} +Const + DBUseErrorMessage : DBaseUsedErrorMessages = + {$IFDEF DBaseEnglishMessage} + DBEnglish; + {$ELSE} + {$IFDEF DBaseGermanMessage} + DBGerman; + {$ELSE} + DBNoMsg; + {$ENDIF} + {$ENDIF} + +Var + ProcErrorHandler : VoidFct_ErrorHandler; {!!.42} + +Implementation {=========================================================} + + +Const + DBMaxFields = 128; + DBDateFieldWidth = 8; + DBLogicFieldWidth = 1; + DBMemoFieldWidth = 10; + DBMaxCharFieldWidth = 254; + DBMaxNumFieldWidth = 19; + DBMaxNumFieldDecimals = 15; + DB4MaxNumFieldWidth = 20; + DB4MaxNumFieldDecimals = 18; + DBMaxRecSize = 4001; + {-Maximum record size + 1 byte (dBASE delete mark)} + DBMinMemoRecSize = 512; + DBMaxMemoSize = $FFF7; {64 K Bytes - 8 Bytes} + DBDataOnly = $03; + DBDataAndMemo = $83; + DB4DataAndMemo = $8B; + DB4ValidMemoField = $0008FFFF; + DB4ValidMemoFile = $01020000; + DBEndOfHeader = #$0D; + DBEndOfFile = #$1A; + DBEndOfMemoRec = #$1A; + + +Type + CharArr = Array [0 .. $FFFE] Of Char; + PText = ^Text; + PCharArr = ^CharArr; +{$IFNDEF UseSymFlex} {!!.42} + {$IFDEF Ver55} {!!.42} + PChar = ^Char; {!!.42} + {$ENDIF} {!!.42} + {$IFDEF Ver60} {!!.42} + PChar = ^Char; {!!.42} + {$ENDIF} {!!.42} +{$ELSE} {!!.42} + {$IFNDEF SymFlexGE20} {!!.42} + {$IFDEF Ver55} {!!.42} + PChar = ^Char; {!!.42} + {$ENDIF} {!!.42} + {$IFDEF Ver60} {!!.42} + PChar = ^Char; {!!.42} + {$ENDIF} {!!.42} + {$ENDIF} {!!.42} +{$ENDIF} {!!.42} + + +{$IFNDEF SymFlexGE20} + Function GetAZSLength ( AZSPtr : PChar ) : Word; + + Var + L : Word; + + Begin + {$IFDEF Windows} + GetAZSLength := StrLen (AZSPtr); + {$ELSE} + Inline ( + $FC / { Cld } + $C4 / $BE / AZSPtr / { Les DI, AZSPtr [BP] } + $B9 / $FF / $FF / { Mov CX, $FFFF } + $31 / $C0 / { Xor AX, AX } + $F2 / { Repne } + $AE / { Scasb } + $B8 / $FE / $FF / { Mov AX, $FFFE } + $29 / $C8 / { Sub AX, CX } + $89 / $86 / L { Mov [BP+Ofs(L)], AX } + ); + GetAZSLength := L; + {$ENDIF} + End; + + + Function BytePosInMem ( ToFindByte : Byte; + MemPtr : Pointer; + MaxBytes : Word ) : Word; + + Var + LResult : Word; {!!.51} + + Begin + If MaxBytes = 0 Then Begin + BytePosInMem := 0; + End Else Begin + Inline ( + $FC / { Cld } + $C4 / $BE / MemPtr / { Les DI, MemPtr [BP] } + $8B / $8E / MaxBytes / { Mov CX, [BP+Ofs(MaxBytes)] } + $8A / $86 / ToFindByte / { Mov AL, [BP+Ofs(ToFindByte)] } + $F2 / { Repne } + $AE / { Scasb } + $8B / $86 / MaxBytes / { Mov AX, [BP+Ofs(MaxBytes)] } + $74 / $01 / { Jz Found } + $40 / { Inc AX } + {Found:} + $29 / $C8 / { Sub AX, CX } + $89 / $86 / LResult { Mov [BP+Ofs(LResult)], AX }{!!.51} + ); + BytePosInMem := Pred (LResult); {!!.51} + End; + End; +{$ENDIF} + + + Function GetFNameOnly ( FName : IsamFileName ) : IsamFileName; + + Var + {$IFDEF Windows} {!!.42} + Idx : Integer; + {$ELSE} {!!.42} + Dir : DirStr; {!!.42} + Name : NameStr; {!!.42} + Ext : ExtStr; {!!.42} + {$ENDIF} {!!.42} + + Begin + {$IFDEF Windows} {!!.42} + FName := IsamForceExtension ( FName, '' ); + Delete ( FName, Length ( FName ), 1 ); + Idx := Length ( FName ); + While (Idx > 0) And (FName [Idx] <> '\') {!!.42mod} + And (FName [Idx] <> ':') Do Begin {!!.42mod} + Dec ( Idx ); + End; + + GetFNameOnly := Copy ( FName, Succ (Idx), Length ( FName ) - Idx ); + + {$ELSE} {!!.42} + FSplit ( FName, Dir, Name, Ext ); {!!.42} + GetFNameOnly := Name; {!!.42} + {$ENDIF} {!!.42} + End; + + + Function StrUpCase ( Src : String ) : String; {!!.42mod} + + Var + Idx : Byte; + + Begin + For Idx := 1 To Length ( Src ) Do {!!.42mod} + Src [Idx] := UpCase ( Src [Idx] ); + StrUpCase := Src; {!!.42mod} + End; + + + Procedure NoErrorHandler ( Reaction : ErrorReaction; + IsamError : Integer; + DBaseError : DBaseErrorNr ); + + Begin + End; + + + Procedure CallProcErrorHandler ( Reaction : ErrorReaction; + IsamError : Integer; + DBaseError : DBaseErrorNr ); + + Begin + If (@ProcErrorHandler <> @NoErrorHandler) And + (@ProcErrorHandler <> Nil) Then Begin + ProcErrorHandler ( Reaction, IsamError, DBaseError ); + End; + End; + + + Function CallFuncReXUser ( FuncReXUser : IntFct_ReXUser; + Status : WorkStatus; + LHPtr : PListHeader; + ReadRecs, + WriteRecs, + ErrorRecs : Longint; + Var DatSBuf ) : Integer; + + Begin + If (@FuncReXUser <> @NoReXUser) And + (@FuncReXUser <> Nil) Then Begin + CallFuncReXUser := FuncReXUser ( Status, LHPtr, ReadRecs, + WriteRecs, ErrorRecs, DatSBuf ); + End Else Begin + CallFuncReXUser := 0; + End; + End; + + + Procedure CallProcCArrConv ( ProcCArrConv : VoidFct_CharArrConvert; + CArrPtr : Pointer; + Len : Word ); + + Begin + If (@ProcCArrConv <> @NoCArrConv) And + (@ProcCArrConv <> Nil) Then Begin + ProcCArrConv ( CArrPtr, Len ); + End; + End; + + + Function CallFuncDecideWrite ( FuncDecideWrite : EnumFct_DecideWrite; + LHPtr : PListHeader; + Errors : Integer; + Var BTBuf, + DBBuf ) : DecideCase; + + Begin + If @FuncDecideWrite <> Nil Then Begin + CallFuncDecideWrite := FuncDecideWrite ( LHPtr, Errors, BTBuf, + DBBuf); + End Else Begin + CallFuncDecideWrite := DCWrite; + End; + End; + + + Function StdDecideWrite ( LHPtr : PListHeader; + Errors : Integer; + Var BTBuf, + DBBuf ) : DecideCase; + + Begin + If LHPtr^.DBSource Then Begin + If Char ( DBBuf ) = ' ' Then Begin + StdDecideWrite := DCWrite; + End Else Begin + StdDecideWrite := DCSkip; + End; + End Else Begin + If Longint ( BTBuf ) = 0 Then Begin + StdDecideWrite := DCWrite; + End Else Begin + StdDecideWrite := DCSkip; + End; + End; + End; + + + Procedure NoCArrConv ( CArrPtr : Pointer; + Len : Word ); + + Begin + End; + + + Function NoReXUser ( Status : WorkStatus; + LHPtr : PListHeader; + ReadRecs, + WriteRecs, + ErrorRecs : Longint; + Var DatSBuf ) : Integer; + + Begin + End; + + + Function DBaseErrorMessage ( ErrorNr : DBaseErrorNr ) : String; + + Begin + If (DEEOF < ErrorNr) And (ErrorNr < DELAST) Then Begin + Case DBUseErrorMessage Of + DBNoMsg : Begin + DBaseErrorMessage := ''; + End; + + DBGerman : Begin + {$IFDEF DBaseGermanMessage} + Case ErrorNr Of + DEEOF : DBaseErrorMessage := 'Dateiende erreicht'; + DEOOM : DBaseErrorMessage := 'Nicht gengend Speicher frei'; + DEBV : DBaseErrorMessage := 'Falsche Version oder es ist ' + + 'keine dBASE III/VI Datei'; + DECMF : DBaseErrorMessage := 'Format der Memo-Datei stimmt nicht ' + + 'oder die Datei ist korrumpiert'; + DERSTL : DBaseErrorMessage := 'Datensatz ist zu gro'; + DEWCT : DBaseErrorMessage := 'Falscher CType'; + DEEWTD : DBaseErrorMessage := 'Fehler beim Schreiben der ' + + 'Typdefinitionsdatei'; + DEECF : DBaseErrorMessage := 'Feld konnte nicht konvertiert ' + + 'werden'; + DELHNI : DBaseErrorMessage := 'ListHeader ist nicht ' + + 'oder falsch initialisiert'; + DETMF : DBaseErrorMessage := 'Zu viele Felder'; + DEWFT : DBaseErrorMessage := 'Ungltiger Feldtyp'; + DEFWTL : DBaseErrorMessage := 'Feldlnge zu gro'; + DETMD : DBaseErrorMessage := 'Zuviele Dezimalstellen'; + DEFTVC : DBaseErrorMessage := 'Feldtyp pat nicht zur dBASE-' + + 'Version'; + DEARFNA : DBaseErrorMessage := 'Autorelationen sind an dieser ' + + 'Stelle nicht erlaubt'; + DEFCNMF : DBaseErrorMessage := 'Datei enthlt keine Memofelder'; + DEEODF : DBaseErrorMessage := 'Fehler beim ffnen der Dumpdatei'; + DEEWDF : DBaseErrorMessage := 'Fehler beim Schreiben der ' + + 'Dumpdatei'; + DEECDF : DBaseErrorMessage := 'Fehler beim Schlieen der ' + + 'Dumpdatei'; + DEPE : DBaseErrorMessage := 'Programmierfehler'; + DEFNAE : DBaseErrorMessage := 'Feldname existiert schon'; + DENFD : DBaseErrorMessage := 'Kein Feld definiert'; + End; + {$ENDIF} + End; + + DBEnglish : Begin + {$IFDEF DBaseEnglishMessage} + Case ErrorNr Of + DEEOF : DBaseErrorMessage := 'End of file'; + DEOOM : DBaseErrorMessage := 'Out of memory'; + DEBV : DBaseErrorMessage := 'Bad version or is not an ' + + 'dBASE III/IV file'; + DECMF : DBaseErrorMessage := 'Corrupted memo file'; + DERSTL : DBaseErrorMessage := 'Record size to large'; + DEWCT : DBaseErrorMessage := 'Wrong CType'; + DEEWTD : DBaseErrorMessage := 'Error writing type definition' + + ' file'; + DEECF : DBaseErrorMessage := 'Error converting field'; + DELHNI : DBaseErrorMessage := 'List header not initialized ' + + 'or bad part'; + DETMF : DBaseErrorMessage := 'Too many fields'; + DEWFT : DBaseErrorMessage := 'Wrong field type'; + DEFWTL : DBaseErrorMessage := 'Field width too large'; + DETMD : DBaseErrorMessage := 'Too many decimals'; + DEFTVC : DBaseErrorMessage := 'Field type version conflict'; + DEARFNA : DBaseErrorMessage := 'Auto relation field is not ' + + 'allowed here'; + DEFCNMF : DBaseErrorMessage := 'File contains no memo fields'; + DEEODF : DBaseErrorMessage := 'Error opening dump file'; + DEEWDF : DBaseErrorMessage := 'Error writing dump file'; + DEECDF : DBaseErrorMessage := 'Error closing dump file'; + DEPE : DBaseErrorMessage := 'Programming error'; + DEFNAE : DBaseErrorMessage := 'Field name already exists'; + DENFD : DBaseErrorMessage := 'No field defined'; + End; + {$ENDIF} + End; + End; + END ELSE BEGIN + DBaseErrorMessage := ''; + End; + End; + + + Function DBaseEOF ( LHPtr : PListHeader ) : Boolean; + + Begin + DBaseEOF := LHPtr^.DBHeaderPtr^.RefNr > + LHPtr^.DBHeaderPtr^.Header.NrOfRecs; + End; + + + Function DBaseGo ( LHPtr : PListHeader; + Ref : Longint ) : Integer; + + Var + Position : Longint; + + Begin + IsamClearOK; {!!.52} + If (Ref <= 0 ) And ( LHPtr^.DBHeaderPtr^.Header.NrOfRecs < Ref ) + Then Begin + CallProcErrorHandler ( ERIgnore, 0, DEEOF ); + End; + LHPtr^.DBHeaderPtr^.RefNr := Ref; + Position := LHPtr^.DBHeaderPtr^.Header.HeaderSize + + ( LHPtr^.DBHeaderPtr^.RefNr - 1 ) * + Longint ( LHPtr^.DBHeaderPtr^.Header.RecordSize ); + IsamLongSeek ( LHPtr^.DBHeaderPtr^.IFile, Position ); + If Not IsamOK Then Begin + DBaseGo := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + DBaseGo := 0; + End; + + + Function DBaseSkip ( LHPtr : PListHeader ) : Integer; + + Begin + DBaseSkip := DBaseGo ( LHPtr, LHPtr^.DBHeaderPtr^.RefNr + 1 ); + End; + + + Procedure UndoDBaseImpExp ( LHPtr : PListHeader; + IsamBufPtr , + DBaseBufPtr : Pointer; + IsamBufSize, + DBaseBufSize : Word ); + + Var + Dummy : Integer; + + Begin + If LHPtr^.DBSource Then Begin + Dummy := CloseIsamFiles ( LHPtr ) + End Else Begin + Dummy := CloseDBaseFiles ( LHPtr ); + End; + + If IsamBufPtr <> Nil Then FreeMem ( IsamBufPtr, IsamBufSize ); + If DBaseBufPtr <> Nil Then FreeMem ( DBaseBufPtr, DBaseBufSize ); + End; + + + Function OpenDumpFile ( Var DumpFilePtr : PText; + DumpFName : IsamFileName ) : Integer; + + Begin + OpenDumpFile := -1; + + If MaxAvail < SizeOf ( Text ) Then Begin + CallProcErrorHandler ( ERIgnore, 0, DEEODF ); + Exit; + End; + GetMem ( DumpFilePtr, SizeOf ( Text ) ); + + Assign ( DumpFilePtr^, DumpFName ); + Rewrite ( DumpFilePtr^ ); + If IOResult <> 0 Then Begin + FreeMem ( DumpFilePtr, SizeOf ( Text ) ); + DumpFilePtr := Nil; + CallProcErrorHandler ( ERIgnore, 0, DEEODF ); + Exit; + End; + + OpenDumpFile := 0; + End; + + + Function CloseDumpFile ( Var DumpFilePtr : PText ) : Integer; + + Var {!!.42} + LResult : Word; {!!.42}{!!.51} + + Begin + CloseDumpFile := 0; + If DumpFilePtr = Nil Then Exit; + + Close ( DumpFilePtr^ ); + FreeMem ( DumpFilePtr, SizeOf ( Text ) ); + DumpFilePtr := Nil; + LResult := IOResult; {!!.42}{!!.51} + If LResult <> 0 Then Begin {!!.42}{!!.51} + CloseDumpFile := LResult; {!!.42}{!!.51} + CallProcErrorHandler ( ERIgnore, 0, DEECDF ); + End; + End; + + + Function WriteDump ( Var DumpFilePtr : PText; + LHPtr : PListHeader; + Errors : Integer ) : Integer; + + Var + LResult: Integer; {!!.51} + CurFNPtr : PFieldNode; + i, + Width : Integer; + DumpFName : IsamFileName; + + Begin + If LHPtr = Nil Then Exit; + + If DumpFilePtr = Nil Then Begin + If LHPtr^.DBSource Then Begin + DumpFName := LHPtr^.DBHeaderPtr^.IFile.Name; + End Else Begin + DumpFName := BTDataFileName ( LHPtr^.BTHeaderPtr^.FBPtr ); + End; + DumpFName := IsamForceExtension ( DumpFName, DumpExtension ); {!!.42mod} + + LResult := OpenDumpFile ( DumpFilePtr, DumpFName ); {!!.51} + If LResult <> 0 Then Begin {!!.51} + WriteDump := LResult; {!!.51} + Exit; + End; + End; + + Writeln ( DumpFilePtr^, + 'Record number: ', LHPtr^.DBHeaderPtr^.RefNr : 8, + ' Number of errors: ', Errors ); + LResult := IOResult; {!!.42}{!!.51} + If LResult <> 0 Then Begin {!!.42}{!!.51} + WriteDump := LResult; {!!.42}{!!.51} + CallProcErrorHandler ( ERIgnore, 0, DEEWDF ); + LResult := CloseDumpFile ( DumpFilePtr ); {!!.51} + Exit; + End; + + CurFNPtr := LHPtr^.ListPtr; + While CurFNPtr <> Nil Do Begin + If CurFNPtr^.ConvStatus <> 0 Then Begin + Writeln ( DumpFilePtr^, 'Field name: ', CurFNPtr^.FieldName ); + LResult := IOResult; {!!.42}{!!.51} + If LResult <> 0 Then Begin {!!.42}{!!.51} + WriteDump := LResult; {!!.42}{!!.51} + CallProcErrorHandler ( ERIgnore, 0, DEEWDF ); + LResult := CloseDumpFile ( DumpFilePtr ); {!!.51} + Exit; + End; + End; + CurFNPtr := CurFNPtr^.NextPtr; + End; + + WriteDump := 0; + End; + + + Procedure FreeFieldList ( Var ListPtr : PFieldNode ); + + Var + CurFNPtr : PFieldNode; + + Begin + While ListPtr <> Nil Do Begin + CurFNPtr := ListPtr; + ListPtr := ListPtr^.NextPtr; + If CurFNPtr^.DBFieldPtr <> Nil Then + FreeMem ( CurFNPtr^.DBFieldPtr, SizeOf ( DBaseField ) ); + If CurFNPtr^.BTFieldPtr <> Nil Then + FreeMem ( CurFNPtr^.BTFieldPtr, SizeOf ( IsamField ) ); + FreeMem ( CurFNPtr, SizeOf ( FieldNode ) ); + End; + End; + + + Procedure FreeListHeader ( Var LHPtr : PListHeader ); + + Begin + If LHPtr = Nil Then Exit; + + If LHPtr^.DBHeaderPtr <> Nil Then Begin + If LHPtr^.DBHeaderPtr^.MemoPtr <> Nil Then Begin + FreeMem ( LHPtr^.DBHeaderPtr^.MemoPtr, SizeOf ( DBaseMemo ) ); + End; + FreeMem ( LHPtr^.DBHeaderPtr, SizeOf ( DBaseHeader ) ); + End; + + If LHPtr^.BTHeaderPtr <> Nil Then Begin + FreeMem ( LHPtr^.BTHeaderPtr, SizeOf ( IsamHeader ) ); + End; + + If LHPtr^.ListPtr <> Nil Then Begin + FreeFieldList ( LHPtr^.ListPtr ); + End; + + FreeMem ( LHPtr, SizeOf ( ListHeader ) ); + LHPtr := Nil; + End; + + + Procedure SetDateOfToDay ( Var LastChange : DBaseFileDate ); + + Var + Year, + Month, + Day, + DayOfWeek : Word; + + Begin + GetDate ( Year, Month, Day, DayOfWeek ); + If ( Year > 100) And ( Year < 2000 ) Then + Dec ( Year, 1900 ); + LastChange.Year := Byte ( Year ); + LastChange.Month := Byte ( Month ); + LastChange.Day := Byte ( Day ); + End; + + + Function CloseDBaseFiles ( LHPtr : PListHeader ) : Integer; + + Begin + CloseDBaseFiles := -1; + IsamClearOK; + + If LHPtr = Nil Then Exit; + If LHPtr^.DBHeaderPtr = Nil Then Exit; + If LHPtr^.DBHeaderPtr^.Modified Then Begin + SetDateOfToDay ( LHPtr^.DBHeaderPtr^.Header.LastChange ); + IsamLongSeek ( LHPtr^.DBHeaderPtr^.IFile, 0 ); + If Not IsamOK Then Begin + CloseDBaseFiles := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + IsamBlockWrite ( LHPtr^.DBHeaderPtr^.IFile, + LHPtr^.DBHeaderPtr^.Header, SizeOf ( DBaseFileHeader ) ); + If Not IsamOK Then Begin + CloseDBaseFiles := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + LHPtr^.DBHeaderPtr^.Modified := False; + End; + If LHPtr^.DBHeaderPtr^.IFile.Handle <> 65535 Then Begin + IsamClose (LHPtr^.DBHeaderPtr^.IFile); + If Not IsamOK Then Begin + CloseDBaseFiles := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + End; + + If LHPtr^.DBHeaderPtr^.MemoPtr = Nil Then Begin + CloseDBaseFiles := 0; + Exit; + End; + If LHPtr^.DBHeaderPtr^.MemoPtr^.Modified Then Begin + IsamLongSeek ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, 0 ); + If Not IsamOK Then Begin + CloseDBaseFiles := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + IsamBlockWrite ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile, + LHPtr^.DBHeaderPtr^.MemoPtr^.Header.NextFree, + SizeOf ( LHPtr^.DBHeaderPtr^.MemoPtr^.Header.NextFree ) ); + If Not IsamOK Then Begin + CloseDBaseFiles := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + LHPtr^.DBHeaderPtr^.MemoPtr^.Modified := False; + End; + If LHPtr^.DBHeaderPtr^.MemoPtr^.IFile.Handle <> 65535 Then Begin + IsamClose ( LHPtr^.DBHeaderPtr^.MemoPtr^.IFile ); + If Not IsamOK Then Begin + CloseDBaseFiles := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + End; + + CloseDBaseFiles := 0; + End; + + + Function CloseIsamFiles ( LHPtr : PListHeader ) : Integer; + + Begin + CloseIsamFiles := -1; + IsamClearOK; + + If LHPtr = Nil Then Exit; + If LHPtr^.BTHeaderPtr = Nil Then Exit; + If LHPtr^.BTHeaderPtr^.FBPtr = Nil Then Exit; + + BTCloseFileBlock ( LHPtr^.BTHeaderPtr^.FBPtr ); + If Not IsamOK Then Begin + CloseIsamFiles := BTIsamErrorClass; + CallProcErrorHandler ( ERAbort, IsamError, DEZERO ); + Exit; + End; + CloseIsamFiles := 0; + End; + + + Function CheckListHeaderPtr ( LHPtr : PListHeader; + DBSource : Boolean ) : Boolean; + + Begin + CheckListHeaderPtr := False; + + If LHPtr = Nil Then Exit; + If LHPtr^.ListPtr = Nil Then Exit; + If LHPtr^.BTHeaderPtr = Nil Then Exit; + If LHPtr^.DBHeaderPtr = Nil Then Exit; + If LHPtr^.DBSource <> DBSource Then Exit; + + CheckListHeaderPtr := True; + End; + + +{$I dbimpexp.in1} +{$I dbimpexp.in2} + + +Begin + ProcErrorHandler := NoErrorHandler; {!!.42} +End. diff --git a/src/wc_sdk/desq.pas b/src/wc_sdk/desq.pas new file mode 100755 index 0000000..29cf71f --- /dev/null +++ b/src/wc_sdk/desq.pas @@ -0,0 +1,131 @@ +{$O-} + +unit Desq; + +interface + +var + InDv : Boolean; + +const + TimeSlicing : Boolean = False; + +procedure WcDelay(MS : LongInt); +procedure DvPause; + +implementation + +{$IFDEF FPC} +uses + Dos; + + procedure DvPause; + begin + { No DESQview under FPC; just yield timeslice if enabled } + { INT 2Fh/1680h is the standard multitasker yield call } + { Under go32v2 this would need realintr, but for simplicity } + { we just do nothing - the delay loop handles timing } + end; + + procedure WcDelay(MS : LongInt); + var + H, M, S, S100 : Word; + StartTime, ThisTime, EndTime : LongInt; + cOneDay : LongInt; + begin + if MS <= 0 then Exit; + cOneDay := LongInt(1000) * 60 * 60 * 24; + Dos.GetTime(H, M, S, S100); + StartTime := ((((((LongInt(H) * 60) + M) * 60) + S) * 100) + S100) * 10; + EndTime := StartTime + MS; + repeat + Dos.GetTime(H, M, S, S100); + ThisTime := ((((((LongInt(H) * 60) + M) * 60) + S) * 100) + S100) * 10; + { handle midnight rollover } + if (EndTime >= cOneDay) then begin + if (ThisTime < StartTime) then + ThisTime := ThisTime + cOneDay; + end; + until ThisTime >= EndTime; + end; + +{$ELSE FPC} +{ TP7 implementation with DESQview detection and BIOS timer } + + procedure WcDelay(MS : LongInt); + var + BiosTime : LongInt absolute $40:$6C; + Ticks : Word; + Elapsed, StartTime : LongInt; + + begin + StartTime := BiosTime; + Ticks := MS div 55; + repeat + Elapsed := BiosTime - StartTime; + if Elapsed < 0 then + Inc(Elapsed, 1573039); + if Elapsed < Ticks then + DvPause; + until Elapsed > Ticks; + end; + + function DvGetVersion : Word; assembler; + asm + mov cx,'DE' + mov dx,'SQ' + mov ax,2b01h + int 21h + cmp al,0ffh + je @NoDv + xchg ax,bx + mov InDv,1 + jmp @GetDvExit + @NoDv: + xor ax,ax + mov InDv,0 + @GetDvExit: + end; + + + procedure DvPause; assembler; + asm + cmp InDv,1 + jne @NoDv + mov bx,1000h + mov ax,101ah + int 15h + mov ax,bx + int 15h + mov ax,1025h + int 15h + @NoDv: + cmp TimeSlicing,0 + jz @NoSlice + mov ax,1680h {release time slice for Windows & OS/2} + int 2fh + @NoSlice: + end; + +PROCEDURE DV_APICall(func: WORD); INLINE( +$5B/ { pop bx } +$B8/$101A/ { mov ax,101ah } +$CD/$15/ { int 15h } +$89/$D8/ { mov ax,bx } +$CD/$15/ { int 15h } +$B8/$1025/ { mov ax,1025h } +$CD/$15 { int 15h } +); + +{$ENDIF FPC} + +begin +{$IFDEF FPC} + InDv := False; +{$ELSE FPC} + if DvGetVersion = 0 then + {ignore}; +{$ENDIF FPC} + +end. +{.F+} diff --git a/src/wc_sdk/dossupp.pas b/src/wc_sdk/dossupp.pas new file mode 100644 index 0000000..09d2d83 --- /dev/null +++ b/src/wc_sdk/dossupp.pas @@ -0,0 +1,186 @@ +{********************************************************************} +{* DOSSUPP.PAS - DOS support routines for Delphi 1 *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} + +{$IFNDEF VER80} + !! Error - this unit can only be compiled by Delphi 1 +{$ENDIF} + +unit DosSupp; + +interface + +uses + SysUtils, + WinProcs, + WinTypes; + +type + DOSRegisters = record + case Integer of + 0: (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: Word); + 1: (AL, AH, BL, BH, CL, CH, DL, DH: Byte); + end; + +procedure Intr(IntNo : Byte; var Regs: DOSRegisters); +procedure MsDos(var Regs: DOSRegisters); +function DosVersion: Word; +procedure GetIntVec(IntNo: Byte; var Vector: Pointer); +procedure SetIntVec(IntNo: Byte; Vector: Pointer); +procedure GetDate(var Year, Month, Day, DayOfWeek: Word); +procedure GetTime(var Hour, Minute, Second, Sec100: Word); + +implementation + +procedure Intr(IntNo : Byte; var Regs: DOSRegisters); assembler; +asm + push ds + + push cs {!!.52} + call AllocCStoDSAlias {!!.52} + mov ds, ax + lea di, @@IntrCall + mov al, IntNo + mov [di+1], al + push ds {!!.52} + + lds si, Regs {set up the registers from the} + mov ax, [si].DOSRegisters.&SI { DOSRegisters structure } + push ax + mov ax, [si].DOSRegisters.&DS + or ax, ax + jnz @@SetDS + mov ax, ds + + @@SetDS: + push ax + mov di, [si].DOSRegisters.&DI + mov bp, [si].DOSRegisters.&BP + mov bx, [si].DOSRegisters.&BX + mov dx, [si].DOSRegisters.&DX + mov cx, [si].DOSRegisters.&CX + mov ax, [si].DOSRegisters.&AX + mov si, [si].DOSRegisters.&ES + or si, si + jnz @@SetES + mov si, ds {!!.52} + + @@SetES: + mov es, si + pop ds + pop si + + @@IntrCall: + int 0 {do the interrupt} + + push ds {get ready for setting the} + pushf { DOSRegisters structure} + push bp + push si + mov bp, sp {restore our stack frame} + {$IFOPT W+} {!!.52} + add bp, 14 {!!.52} + {$ELSE} {!!.52} + add bp, 12 {!!.52} + {$ENDIF} {!!.52} + lds si, Regs {set up the DOSRegisters structure} + mov [si].DOSRegisters.&DI, di + mov [si].DOSRegisters.&BX, bx + mov [si].DOSRegisters.&DX, dx + mov [si].DOSRegisters.&CX, cx + mov [si].DOSRegisters.&AX, ax + mov [si].DOSRegisters.&ES, es + pop ax + mov [si].DOSRegisters.&SI, ax + pop ax + mov [si].DOSRegisters.&BP, ax + pop ax + mov [si].DOSRegisters.&Flags, ax + pop ax + mov [si].DOSRegisters.&DS, ax + + pop ds + lea di, @@IntrCall + xor al, al + mov [di+1], al {!!.52} + + pop ax {!!.52} + push ds {!!.52} + mov ds, ax {!!.52} + call FreeSelector {!!.52} +end; + +procedure MsDos(var Regs: DOSRegisters); +begin + Intr($21, Regs); +end; + +function DosVersion: Word; assembler; +asm + mov ax, $3000 + call Dos3Call +end; + +procedure GetIntVec(IntNo: Byte; var Vector: Pointer); assembler; +asm + mov ah, $35 + mov al, IntNo + call Dos3Call + mov ax, es + les di, Vector + mov es:[di], bx + mov es:[di+2], ax +end; + +procedure SetIntVec(IntNo: Byte; Vector: Pointer); assembler; +asm + push ds + mov ah, $25 + mov al, IntNo + lds dx, Vector + call Dos3Call + pop ds +end; + +procedure GetDate(var Year, Month, Day, DayOfWeek: Word); +begin + DecodeDate(Date, Year, Month, Day); + DayOfWeek := SysUtils.DayOfWeek(Date); +end; + +procedure GetTime(var Hour, Minute, Second, Sec100: Word); +begin + DecodeTime(Time, Hour, Minute, Second, Sec100); +end; + +end. diff --git a/src/wc_sdk/dpmi.pas b/src/wc_sdk/dpmi.pas new file mode 100644 index 0000000..9a709a0 --- /dev/null +++ b/src/wc_sdk/dpmi.pas @@ -0,0 +1,763 @@ +{$S-,R-,V-,I-,B-,F+} + +{$IFNDEF Ver40} + {$R-,A-} +{$ENDIF} + +{$IFDEF DPMI} + {$DEFINE PMODE} +{$ENDIF} +{$IFDEF Windows} + {$DEFINE PMODE} +{$ENDIF} + +{$IFDEF PMODE} + {$G+} +{$ELSE} + {$O-} +{$ENDIF} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +unit Dpmi; {primitive routines for DPMI management} + +interface + +{-The following consts are used throughout Object Professional. Your code + is free to reference them, but they must *not* be changed.} +const + DpmiInUse : Boolean = False; {True if running in protected mode} + ColorSele : Word = $B800; {selector/segment for color video} + MonoSele : Word = $B000; {selector/segment for mono video} + BiosDataSele : Word = $0040; {selector/segment for bios data area} + BiosSele : Word = $F000; {selector/segment for bios memory} + + +{$IFDEF PMODE} +type + {.Z+} + DoubleWord = record + LoWord : Word; + HiWord : Word; + end; + + DPMIRegisters = {!!.31, added AL, AH, ..., DH} + record + DI : LongInt; + SI : LongInt; + BP : LongInt; + Reserved : LongInt; + case integer of + 1 : (BX : LongInt; + DX : LongInt; + CX : LongInt; + AX : LongInt; + Flags : Word; + ES : Word; + DS : Word; + FS : Word; + GS : Word; + IP : Word; + CS : Word; + SP : Word; + SS : Word); + 2 : (BL, BH : Byte; EBXH : Word; + DL, DH : Byte; EDXH : Word; + CL, CH : Byte; ECXH : Word; + AL, AH : Byte; EAXH : Word); + end; + + MemInfoRec = + record + LargestFreeBlock : LongInt; + MaxUnlockedPages : LongInt; + MaxLockedPages : LongInt; + LinearAddrPages : LongInt; + TotalUnlockedPages : LongInt; + TotalFreePages : LongInt; + TotalPhysicalPages : LongInt; + FreeLinearPages : LongInt; + PageSize : LongInt; + Reserved : Array[1..$C] of Byte; + end; + + DPMIInfoRec = + record {Information returned by GetDPMIInfo routine} + MinorVersion : Byte; + MajorVersion : Byte; + Flags : Word; + SlavePICInt : Byte; + MasterPICInt : Byte; + Processor : Byte; + end; + +type + DescriptorTableEntry = + record + LimitL : Word; + BaseL : Word; + Words : Array[0..1] of Word; + end; + {.Z-} + +function Linear(P : Pointer) : LongInt; + {-Converts a pointer to a linear address to allow differences in addresses + to be calculated. The pointer must be in the range $0:$0 to $FFFF:$000F.} + +function UnLinear(L : LongInt) : Pointer; + {-Converts a linear address to a pointer to allow selector base addresses to + be converted to pointers. The longInt must be in the range $0 to $000FFFFF.} + +function ValidPointer(P : Pointer) : Boolean; {!!.22 new} + {-verify a pmode pointer is valid, by verifying the access rights and limit + on the selector and verifying the selector is write-able. This only checks + the specific pointer address; if you will be accessing a range from the + pointer you should validate the maximum possible offset for the pointer + as well.} + +function AllocLDTDescriptors(NumOfDesc : Word; var BaseSelector : Word) : Word; + {-Allocates one or more descriptors in the task's Local Descriptor Table + (LDT). The descriptor is not initialized; this must be done with calls to + SetSegmentBaseAddr and SetSegmentLimit. The allocated descriptor will be + set to "data" with a priviledge level equal to the application's code + segment priviledge level. If requesting more than one descriptor, the + BaseSelector will be set to the first of a contiguous array of + descriptors. The Selector values for subsequent descriptors in the array + must be calculated by adding the value returned by GetSelectorIncrement.} + +function GetSelectorIncrement : Word; + {-gets the selector increment value} + +function SetSegmentBaseAddr(Selector : Word; BaseAddress : LongInt) : Word; + {-Sets the base (starting) address for Selector} + +function SetSegmentLimit(Selector : Word; Limit : LongInt) : Word; + {-Sets the limit (length) for Selector} + +function GetSegmentBaseAddr(Selector : Word; var BaseAddress: LongInt) : Word; + {-Gets the base (starting) address for Selector} + +function GetSegmentLimit(Selector : Word; var Limit : LongInt) : Word; + {-Gets the limit (length) for Selector} + +function FreeLDTDescriptor(Selector : Word) : Word; + {-Deallocates Selector} + +function GetSelectorForRealMem(RealPtr : Pointer; Limit : LongInt; var Selector : Word) : Word; + {-Allocates Selector of Size bytes in Real memory, starting at RealPtr} + +function GetDescriptor(Selector : Word; + var Descriptor : DescriptorTableEntry) : Word; + {-Gets the Descriptor Table information on Selector, returns 0 if successful} + +function CallFarRealModeProc(StackWords : Word; StackData : Pointer; + var Regs : DPMIRegisters) : Word; + {-Simulates a FAR CALL to a real mode procedure.} + +function SimulateRealModeInt(IntNo : Byte; + var Regs : DPMIRegisters) : Word; + {-Simulates an interrupt in real mode. Control is transferred to the + address specified by the real mode interrupt vector.} + +procedure GetRealModeIntVector(IntNo : Byte; var Vector : Pointer); + {-Returns the contents of the current virtual machine's real mode interrupt + vector number for IntNo. Note, the returned address is a real mode + segment:offset.} + +procedure SetRealModeIntVector(IntNo : Byte; Vector : Pointer); + {-Set the current virtual machine's real mode interrupt vector for + vector IntNo. Vector must be a real mode segment:offset.} + +function AllocRealModeCallbackAddr(CallbackProc : Pointer; + var Regs : DPMIRegisters; + var Callback : Pointer) : Word; + {-Allocates a unique real mode segment:offset that will transfer control + from real mode to a protected mode procedure.} + +function FreeRealModeCallbackAddr(Callback : Pointer) : Word; + {-Frees a real mode callback previously allocated with + AllocateRealModeCallbackAddr.} + +procedure GetProtectedModeInt(IntNo : Byte; var Handler : Pointer); + {-Returns the address of the current protected mode interrupt handler for + IntNo.} + +function SetProtectedModeInt(IntNo : Byte; Handler : Pointer) : Word; + {-Sets the address of the protected mode handler for IntNo.} + +procedure GetDPMIMemInfo(var MemInfo : MemInfoRec); + {-Returns information about the amount of available physical memory, linear + address space, and disk space for page swapping. See the MemInfoRec + declared above for information on the returned values. Only the first + field of the MemInfoRec is guantanteed to be valid. All invalid fields + will be set to -1.} + +{$ENDIF} + +implementation + + +{$IFDEF PMODE} +type + OS = + record + O, S : Word; + end; + +var + DpmiPrimExitPtr : Pointer; + + function Linear(P : Pointer) : LongInt; + {-Converts a pointer to a linear address to allow differences in addresses + to be calculated. The pointer must be in the range $0:$0 to $FFFF:$000F.} + begin + with OS(P) do + Linear := (LongInt(S) shl 4)+LongInt(O); + end; + + function UnLinear(L : LongInt) : Pointer; + {-Converts a linear address to a pointer allow selector base addresses to + be converted to pointers. The longInt must be in the range $0 to $000FFFFF.} + begin + UnLinear := Ptr(Word(L shr 4), Word(L and $000F)); {!!.21} + end; + + function ValidPointer(P : Pointer) : Boolean; Assembler; {!!.22 new} + {-verify a pmode pointer is valid} + asm + push dx; {preserve dx} + push bx; {preserve bx} + xor ax,ax; {assume failure} + mov dx,[bp+8]; {get selector portion of pointer} + lar bx,dx; {get Access Rights byte} + jnz @@Out; {bad selector, get out} + lsl bx,dx; {get Selector Limit} + jnz @@Out; {bad selector, get out} + cmp bx,[bp+6]; {compare selector limit to offset of pointer} + jb @@Out; {limit is less, get out} + verw dx; {is selector writable?} + jnz @@Out; {nope, get out} + mov al,1; {return True} +@@Out: + pop bx; {restore bx} + pop dx; {restore dx} + end; + + function CallFarRealModeProc(StackWords : Word; StackData : Pointer; + var Regs : DPMIRegisters) : Word; Assembler; + asm + push ds; + mov cx,StackWords; + jcxz @@NoParams; + lds si,StackData; + mov ax,cx; + dec ax; + shl ax,1; + add si,ax; + std; + @@ParamLoop: + lodsw; + push ax; + loop @@ParamLoop; + @@NoParams: + cld; + xor bx,bx; + mov cx,StackWords; + les di,Regs; + mov ax,0301h; + int 31h; + jc @@ExitPoint; + xor ax,ax; + @@ExitPoint: + mov bx,StackWords; + shl bx,1; + add sp,bx; + pop ds; + end; + + function SimulateRealModeInt(IntNo : Byte; + var Regs : DPMIRegisters) : Word; Assembler; + asm + xor bx,bx; + mov bl,IntNo; + xor cx,cx; {StackWords = 0} + les di,Regs; + mov ax,0300h; + int 31h; + jc @@ExitPoint; + xor ax,ax; + @@ExitPoint: + end; + + procedure GetRealModeIntVector(IntNo : Byte; var Vector : Pointer); Assembler; + asm + mov ax,0200h; + mov bl,IntNo; + int 31h; + les di,Vector; + mov word ptr es:[di],dx; + mov word ptr es:[di+2],cx; + end; + + procedure SetRealModeIntVector(IntNo : Byte; Vector : Pointer); assembler; + asm + mov ax,$0201; + mov bl,IntNo; + mov dx,word ptr Vector; + mov cx,word ptr Vector+2; + int $31; + end; + + function GetCPUFlags : Byte; Assembler; + asm + lahf; + mov al,ah; + end; + + {Doesn't work under Windows 3.1. Don't use in Windows!} + function AllocDosMem(SizeInParas : Word; + var RealModeSeg : Word; + var ProtModeSel : Word) : Word; Assembler; + asm + mov bx,SizeInParas; + mov ax,0100h; + int 31h; + jc @@ExitPoint; + les di,RealModeSeg; + mov es:[di],ax; + les di,ProtModeSel; + mov es:[di],dx; + xor ax,ax; + @@ExitPoint: + end; + + {Doesn't work under Windows 3.1. Don't use in Windows!} + function FreeDosMem(ProtModeSel : Word) : Word; Assembler; + asm + mov ax,0101h; + mov dx,ProtModeSel; + int 31h; + jc @@ExitPoint; + xor ax,ax; + @@ExitPoint: + end; + + function AllocLDTDescriptors(NumOfDesc : Word; var BaseSelector : Word) : Word; Assembler; + asm + mov cx,NumOfDesc; + xor ax,ax; + int 31h; + jc @@ErrorExitPoint; {!!.31} + les di,BaseSelector; + mov es:[di],ax; + xor ax,ax; + jmp @@ExitPoint {!!.31} + @@ErrorExitPoint: {!!.31} + mov ax,1 {!!.31} + @@ExitPoint: + end; + + function SetSegmentBaseAddr(Selector : Word; BaseAddress : LongInt) : Word; Assembler; + asm + mov bx,Selector; + mov dx,word ptr BaseAddress; + mov cx,word ptr BaseAddress+2; + mov ax,0007h; + int 31h; + jc @@ExitPoint; + xor ax,ax; + @@ExitPoint: + end; + + function GetSegmentAccessRights(Selector : Word; var Rights : Word) : Word; + var + Status : Word; + Descriptor : DescriptorTableEntry; + begin + Status := GetDescriptor(Selector, Descriptor); + if Status = 0 then + with Descriptor do + Rights := (Words[0] shr 8) or ((Words[1] and $00F0) shl 8); + GetSegmentAccessRights := Status; + end; + + function SetRightsPrim(Selector : Word; Rights : Word) : Word; Assembler; + {-Primitive rights change} + asm + mov bx,Selector; + mov cx,Rights; + mov ax,0009h; + int 31h; + jc @@ExitPoint; + xor ax,ax; + @@ExitPoint: + end; + + function SetSegmentAccessRights(Selector : Word; + ReadWrite : WordBool; Code : WordBool) : Word; + var + Rights : Word; + Status : Word; + begin + Status := GetSegmentAccessRights(Selector, Rights); + if Status <> 0 then begin + SetSegmentAccessRights := Status; + Exit; + end; + + {Modify the Rights mask according to parameters} + if Code then begin + ReadWrite := True; {For code, means segment can be read as well as executed} + Rights := Rights and not $0004; {Code is always expand-up} + Rights := Rights or $0008; {Set Code bit} + end else + Rights := Rights and not $0008; {Clear Code bit} + if ReadWrite then + Rights := Rights or $0002 {Set ReadWrite bit} + else + Rights := Rights and not $0002; {Clear ReadWrite bit} + + {Change the rights} + SetSegmentAccessRights := SetRightsPrim(Selector, Rights); + end; + + function GetSegmentLimit(Selector : Word; var Limit : LongInt) : Word; + var + Status : Word; + Descriptor : DescriptorTableEntry; + begin + Status := GetDescriptor(Selector, Descriptor); + if Status = 0 then + with Descriptor do begin + Limit := LongInt(LimitL) or (LongInt(Words[1] and $0F) shl 16); + {Account for granularity} + if Words[1] and $80 <> 0 then + Limit := Limit*4096; + end; + GetSegmentLimit := Status; + end; + + function GetSegmentBaseAddr(Selector : Word; var BaseAddress : LongInt) : Word; Assembler; + asm + mov bx,Selector; + mov ax,0006h; + int 31h; + jc @@ExitPoint; + xor ax,ax; + les di,BaseAddress; + mov es:[di],dx; + mov es:[di+2],cx; + @@ExitPoint: + end; + + function SetLimitPrim(Selector : Word; Limit : LongInt) : Word; Assembler; + {-Primitive limit change} + asm + mov bx,Selector; + mov dx,word ptr Limit; + mov cx,word ptr Limit+2; + mov ax,0008h; + int 31h; + jc @@ExitPoint; + xor ax,ax; + @@ExitPoint: + end; + + function SetSegmentLimit(Selector : Word; Limit : LongInt) : Word; + var + Rights : Word; + Status : Word; + begin + {Handle limit granularity} + Status := GetSegmentAccessRights(Selector, Rights); + if Status <> 0 then begin + SetSegmentLimit := Status; + Exit; + end; + if Limit > $FFFFF then begin + {Segment larger than 1MB} + if Limit and $FFF <> $FFF then begin + {Not page aligned} + SetSegmentLimit := $8021; + Exit; + end; + Rights := Rights or $8000; {Page-granular} + end else + Rights := Rights and not $8000; {Byte-granular} + + {Assure no overflow when granularity changed} + Status := SetLimitPrim(Selector, 0); + if Status = 0 then + Status := SetRightsPrim(Selector, Rights); + if Status = 0 then + SetSegmentLimit := SetLimitPrim(Selector, Limit); + SetSegmentLimit := Status; + end; + + function FreeLDTDescriptor(Selector : Word) : Word; Assembler; + asm + mov bx,Selector; + mov ax,0001h; + int 31h; + jc @@ExitPoint; + xor ax,ax; + @@ExitPoint: + end; + + function GetSelectorIncrement : Word; Assembler; + asm + mov ax,0003h; + int 31h; + end; + + function GetSelectorForRealMem(RealPtr : Pointer; Limit : LongInt; var Selector : Word) : Word; + + procedure FreeSele; + begin + FreeLDTDescriptor(Selector); + end; + + var + ErrorCode : Word; + + begin + ErrorCode := AllocLDTDescriptors(1, Selector); + if ErrorCode = 0 then begin + ErrorCode := SetSegmentBaseAddr(Selector, Linear(RealPtr)); + if ErrorCode = 0 then begin + ErrorCode := SetSegmentLimit(Selector, Limit); + if ErrorCode <> 0 then + FreeSele; + end + else + FreeSele; + end; + GetSelectorForRealMem := ErrorCode; + end; + + function AllocRealModeCallbackAddr(CallbackProc : Pointer; + var Regs : DPMIRegisters; + var Callback : Pointer) : Word; Assembler; + asm + push ds; + lds si,CallbackProc; + les di,Regs; + mov ax,0303h; + int 31h; + jnc @@Exitpoint; + xor cx,cx; + xor dx,dx; + jmp @@ExitPoint2; + @@ExitPoint: + xor ax,ax; + @@ExitPoint2: + les di,Callback; + mov word ptr es:[di],dx; + mov word ptr es:[di+2],cx; + pop ds; + end; + + function FreeRealModeCallbackAddr(Callback : Pointer) : Word; Assembler; + asm + mov cx,word ptr Callback+2; + mov dx,word ptr Callback; + mov ax,0304h; + int 31h; + jc @@ExitPoint; + xor ax,ax; + @@ExitPoint: + end; + + procedure GetProtectedModeInt(IntNo : Byte; var Handler : Pointer); Assembler; + asm + mov ax,0204h; + mov bl,IntNo; + int 31h; + les di,Handler; + mov word ptr es:[di],dx; + mov word ptr es:[di+2],cx; + end; + + function SetProtectedModeInt(IntNo : Byte; Handler : Pointer) : Word; Assembler; + asm + mov bl,IntNo; + mov dx,word ptr Handler; + mov cx,word ptr Handler+2; + mov ax,0205h; + int 31h; + jc @@ExitPoint; + xor ax,ax; + @@ExitPoint: + end; + + function GetExceptionHandler(ExceptionNum : Byte; + var Handler : Pointer) : Word; Assembler; + asm + mov bl,ExceptionNum; + mov ax,0202h; + int 31h; + jc @@ExitPoint; + xor ax,ax; + les di,Handler; + mov word ptr es:[di],dx; + mov word ptr es:[di+2],cx; + @@ExitPoint: + end; + + function SetExceptionHandler(ExceptionNum : Byte; + Handler : Pointer) : Word; Assembler; + asm + mov bl,ExceptionNum; + mov ax,0203h; + mov dx,word ptr Handler; + mov cx,word ptr Handler+2; + int 31h; + jc @@ExitPoint; + xor ax,ax; + @@ExitPoint: + end; + + + procedure GetDPMIMemInfo(var MemInfo : MemInfoRec); Assembler; + const + SizeOfMemInfoRec = SizeOf(MemInfoRec); + asm + les di,MemInfo; + mov si,di; + mov cx,SizeOfMemInfoRec; + mov al,0FFh; + cld; + rep stosb; {set record to -1 in case DPMI doesn't} + mov di,si; + mov ax,0500h; {get free memory info} + int 31h; {this function doesn't fail} + mov ax,0604h; {get page size} + int 31h; + jc @@ExitPoint; {not supported by 16-bit hosts} + lea di,MemInfoRec(es:[si]).PageSize; + cld; + mov ax,cx; + stosw; + mov ax,bx; + stosw; + @@ExitPoint: + end; + + procedure GetDPMIInfo(var DPMIInfo : DPMIInfoRec); Assembler; + asm + mov ax,0400h; + int 31h; {this function doesn't fail} + les di,DPMIInfo; + cld; + stosw; {store minor and major version numbers} + mov ax,bx; + stosw; {store Flags} + mov ax,dx; + stosw; {store PIC base interrupt numbers} + mov al,cl; + stosb; {store processor type} + end; + + function GetPageSize(var PageSize : LongInt) : Word; Assembler; + asm + mov ax,0604h; + int 31h; + jc @@ExitPoint; + les di,PageSize; + mov es:[di],cx; + mov es:[di+2],bx; + xor ax,ax; + @@ExitPoint: + end; + + function GetDescriptor(Selector : Word; + var Descriptor : DescriptorTableEntry) : Word; Assembler; + asm + mov ax,000Bh; + mov bx,Selector; + les di,Descriptor; + int 31h; + jc @@ExitPoint; + xor ax,ax; + @@ExitPoint: + end; + + procedure DpmiPrimExitProc; + {-Our exit handler for this unit} + begin + ExitProc := DpmiPrimExitPtr; + + {free our BiosSele selector} + if (BiosSele <> 0) then + FreeLDTDescriptor(BiosSele); + + {$IFDEF Windows} + {free our BiosDataSele selector} + if (BiosDataSele <> 0) then + FreeLDTDescriptor(BiosDataSele); + {$ENDIF} + end; + +var + W : Word; + +begin + BiosSele := 0; + {$IFDEF DPMI} + ColorSele := SegB800; + MonoSele := SegB000; + BiosDataSele := Seg0040; + {$ELSE} + ColorSele := 0; + MonoSele := 0; + BiosDataSele := 0; + {$ENDIF} + DpmiInUse := True; + + {set up an exit handler to release our selectors} + DpmiPrimExitPtr := ExitProc; + ExitProc := @DpmiPrimExitProc; + + {since the RTL doesn't provide an important predefined selector, we get one} + W := GetSelectorForRealMem(Ptr($F000, 0), $FFFF, BiosSele); + if W <> 0 then + {failed; generate Runtime Error 203 (out of heap)} + RunError(203); + + {$IFDEF Windows} + {since the Windows RTL doesn't provide another important predefined + selector, we get one} + W := GetSelectorForRealMem(Ptr($0040, 0), $FFFF, BiosDataSele); + if W <> 0 then + {failed; generate Runtime Error 203 (out of heap)} + RunError(203); + {$ENDIF} + +{$ENDIF} +end. + diff --git a/src/wc_sdk/emsheap.pas b/src/wc_sdk/emsheap.pas new file mode 100644 index 0000000..8c8b2aa --- /dev/null +++ b/src/wc_sdk/emsheap.pas @@ -0,0 +1,1576 @@ +{********************************************************************} +{* EMSHEAP.PAS - EMS Heap manager *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + + +{--Definition of mode used for EMS heap} + (********************************************************************) + (****************) { $DEFINE DebugEMSHeap} (*****************) + (****************) { $DEFINE NoErrorCheckEMSHeap} (*****************) + (****************) { $DEFINE ManualInitEMSHeap} (*****************) + (********************************************************************) + {-Possible modes: + no define at all: a minimum error check is done + DebugEMSHeap: a lot of checks are performed, especially at initializition; + use this only in test mode; this overwrites NoErrorCheckEMSHeap + NoErrorCheckEMSHeap: no error check is done to reach maximum performance} + +{--Definition of method how the EMS istalled check is done} + (********************************************************************) + (****************) { $DEFINE StdEMSInstCheck} (*****************) + (********************************************************************) + {-The standard test method can cause problems, so it is deactivated; + activate this define, when EMS is available but not detected by this + unit} + +{--Definition whether to use OPEMS or TPEMS instead of EMSSUPP} + (********************************************************************) + (****************) { $DEFINE UseTPEMS} (*****************) + (****************) { $DEFINE UseOPEMS} (*****************) + (********************************************************************) + +{--Correct and check defines} + {$IFDEF DebugEMSHeap} + {$UNDEF NoErrorCheckEMSHeap} + {$ENDIF} + {$IFDEF UseTPEMS} + {$IFDEF UseOPEMS} + ** ERROR ** Cannot define UseTPEMS and UseOPEMS at the same time + {$ENDIF} + {$ENDIF} + + +Unit EMSHeap; + +Interface + +Uses +{$IFDEF UseOPEMS} + OPEMS; +{$ELSE} + {$IFDEF UseTPEMS} + TPEMS; + {$ELSE} + EMSSupp; + {$ENDIF} +{$ENDIF} + +Const + EMSHeapErrorFuncPtr : Pointer = Nil; + EMSHardErrorFuncPtr : Pointer = Nil; + DoManualInitEMSHeap = + {$IFDEF ManualInitEMSHeap} + True; + {$ELSE} + False; + {$ENDIF} + +Type + EMSPointer = Pointer; + +Var + EMSHeapInitialized : Boolean; + + + Function MapEMSPtr ( EPtr : EMSPointer ) : Pointer; + + Function SaveEMSCtxt : Byte; + + Procedure RestoreEMSCtxt ( HandleInd : Byte ); + + Procedure GetEMSMem ( Var EPtr : EMSPointer; Size : Word ); + + Procedure FreeEMSMem ( EPtr : EMSPointer; Size : Word ); + + Function EMSMemAvail : LongInt; + + Function EMSMaxAvail : Word; + + Procedure InitEMSHeap ( FreePages : Word ); + + Procedure ExitEMSHeap; + + +Implementation + +{$I emsheap.cfg} + +Const + NrOfFreeListPages = 4; + NrOfFreeListEntries = 16383; + MaxAllocPagesForHandle = 256; + PhysPageSize = 16384; + MaxEMSAllocSize = 32768; + NotMapped = $FF; + +Type + PhysPageDescriptor = Array [0..3] Of Word; + + HandleEntry = Record + Handle : Word; + LogPages : Byte; + UsedForSave : Boolean; + PhPgDescr : PhysPageDescriptor; + LRU : Byte; + End; + + HandleArray = Array [-1..HandlesToUseForAlloc] Of HandleEntry; + + FreeListEntry = Record + Offset : Word; {LogPage 15..8, OffsetInPage 7..0} + LenM1 : Byte; {64 Bytes : 0, 16384 Bytes : $FF} + HandleIndex : Byte; + End; + FreeList = Array [1..NrOfFreeListEntries] Of FreeListEntry; + + RealEMSPointer = Record + HandleInds, + LogPageOfs : Word; + {Pointers with size > 16384: + | HandleInd2 15..8 | HandleInd1 7..0 || LogPage1 15..8 | LogPage2 4..0 | + Pointers with size <= 16384: + | zero 15..8 | HandleInd1 7..0 || LogPage1 15..8 | Offset1 7..0 |} + End; + +Const + HeapErrorFuncActive : Boolean = False; + +Var + HandleInfo : HandleArray; + FramePtr : Pointer; + FramePtrSeg : Word; + UsedNrOfFreeListEntries : Word; + PhysPageDescr : PhysPageDescriptor; + {-Word element: | LogPage 12..8 | HandleIndex 7..0 |} + LRUMap : Byte; + {-Two bits for each entry: oldest 7,6; newest 1,0} + + + Function CallHardErrorFunc ( UserRoutine : Pointer; Error : Word ) : Boolean; + + Function CallUserRoutine ( Error : Word ) : Boolean; Inline + {-Call UserRoutine} + ( $FF / $5E / 0 Then Begin + {$IFDEF DebugEMSHeap} + InitFail ( 20 ); + {$ENDIF} + Exit; + End; + + NrOfPages := EMSPagesAvail; + If NrOfPages = EMSErrorCode Then Begin + {$IFDEF DebugEMSHeap} + InitFail ( 4 ); + {$ENDIF} + Exit; + End; + Dec (NrOfPages, FreePages + NrOfFreeListPages); + + If HandlesToUseForAlloc < MinEMSHeapPages Then Begin + {$IFDEF DebugEMSHeap} + InitFail ( 5 ); + {$ENDIF} + Exit; + End; + + If NrOfPages < MinEMSHeapPages Then Begin + {$IFDEF DebugEMSHeap} + InitFail ( 6 ); + {$ENDIF} + Exit; + End; + If NrOfPages > MaxEMSHeapPages Then NrOfPages := MaxEMSHeapPages; + UsedNrOfFreeListEntries := NrOfPages; + + PerHandleAllocSize := NrOfPages Div HandlesToUseForAlloc; + AllocNrOfHandles := HandlesToUseForAlloc - + ( NrOfPages - PerHandleAllocSize * HandlesToUseForAlloc ); + W := PerHandleAllocSize; + If AllocNrOfHandles <= HandlesToUseForAlloc Then Inc (W); + If W > MaxAllocPagesForHandle Then Begin + {$IFDEF DebugEMSHeap} + InitFail ( 7 ); + {$ENDIF} + Exit; + End; + + With HandleInfo [-1] Do Begin + Handle := AllocateEMSPages ( 1 ); + If Handle = EMSErrorCode Then Begin + {$IFDEF DebugEMSHeap} + InitFail ( 8 ); + {$ENDIF} + Exit; + End; + LogPages := 1; + UsedForSave := False; + End; + With HandleInfo [0] Do Begin + Handle := AllocateEMSPages ( Pred (NrOfFreeListPages) ); + If Handle = EMSErrorCode Then Begin + DeAlloc ( -1 ); + {$IFDEF DebugEMSHeap} + InitFail ( 8 ); + {$ENDIF} + Exit; + End; + LogPages := Pred (NrOfFreeListPages); + UsedForSave := False; + End; + + For W := 1 To HandlesToUseForAlloc Do Begin + With HandleInfo [W] Do Begin + If W = Succ (AllocNrOfHandles) Then Inc (PerHandleAllocSize); + Handle := AllocateEMSPages ( PerHandleAllocSize ); + If Handle = EMSErrorCode Then Begin + DeAlloc ( Pred (W) ); + {$IFDEF DebugEMSHeap} + InitFail ( 8 ); + {$ENDIF} + Exit; + End; + LogPages := PerHandleAllocSize; + UsedForSave := False; + End; + End; + + If Not SaveEMSContext ( HandleInfo [-1].Handle ) Then Begin + DeAlloc ( HandlesToUseForAlloc ); + {$IFDEF DebugEMSHeap} + InitFail ( 9 ); + {$ENDIF} + Exit; + End; + HandleInfo [-1].UsedForSave := True; + If Not MapEMSPage ( HandleInfo [-1].Handle, 0, 0 ) Then Begin + DeAlloc ( HandlesToUseForAlloc ); + {$IFDEF DebugEMSHeap} + InitFail ( 10 ); + {$ENDIF} + Exit; + End; + For W := 1 To Pred (NrOfFreeListPages) Do Begin + If Not MapEMSPage ( HandleInfo [0].Handle, Pred (W), W ) Then Begin + DeAlloc ( HandlesToUseForAlloc ); + {$IFDEF DebugEMSHeap} + InitFail ( 10 ); + {$ENDIF} + Exit; + End; + End; + + ActPrivatHandle := 1; + PagesLeft := HandleInfo [ActPrivatHandle].LogPages; + PreInitFail := False; + For W := 1 To NrOfFreeListEntries Do Begin + If W <= NrOfPages Then Begin + If PreInitFail Then Begin + DeAlloc ( HandlesToUseForAlloc ); + {$IFDEF DebugEMSHeap} + InitFail ( 11 ); + {$ENDIF} + Exit; + End; + With FreeList (FramePtr^) [W] Do Begin + HandleIndex := ActPrivatHandle; + Offset := + Word ((HandleInfo [ActPrivatHandle].LogPages) - PagesLeft) Shl 8; + LenM1 := $FF; + End; + If PagesLeft = 1 Then Begin + If ActPrivatHandle < HandlesToUseForAlloc Then Begin + Inc (ActPrivatHandle); + PagesLeft := HandleInfo [ActPrivatHandle].LogPages; + End Else Begin + PreInitFail := True; + End; + End Else Begin + Dec (PagesLeft); + End; + End Else Begin + With FreeList (FramePtr^) [W] Do Begin + HandleIndex := 0; {recognize unused entry} + Offset := 0; + LenM1 := 0; + End; + End; + End; + + If Not SaveEMSContext ( HandleInfo [0].Handle ) Then Begin + DeAlloc ( HandlesToUseForAlloc ); + {$IFDEF DebugEMSHeap} + InitFail ( 12 ); + {$ENDIF} + Exit; + End; + HandleInfo [0].UsedForSave := True; + If Not RestoreEMSContext ( HandleInfo [-1].Handle ) Then Begin + DeAlloc ( HandlesToUseForAlloc ); + {$IFDEF DebugEMSHeap} + InitFail ( 13 ); + {$ENDIF} + Exit; + End; + HandleInfo [-1].UsedForSave := False; + + LRUMap := $1B; {bit coded: 00011011} + For W := 0 To 3 Do Begin + PhysPageDescr [W] := 0; + End; + + DoInit := True; + End; + + + Function MapEMSPtr ( EPtr : EMSPointer ) : Pointer; + {-FreeList must not be mapped on call} + Type + TCEMSPtr = Record + HandleIndsLow, + Dummy1 : Byte; + TCLogPageOfs : Word; + End; + + Var + RealEMSPtr : RealEMSPointer Absolute EPtr; + MapSmall, + MapBig : Byte; + DescriptorSmall, + DescriptorBig : Word; + + + Function EvenToNewest : Byte; + Inline ( + $30 / $E4 / {XOR AH, AH} + $A0 / LRUMap / {MOV AL, [LRUMap]} + $89 / $C2 / {MOV DX, AX} + $D1 / $E0 / {SHL AX, 1} + $D1 / $E0 / {SHL AX, 1} + $F6 / $C4 / $01 / {TEST AH, 01} + $75 / $11 / {JNZ Cont1:} + $88 / $D5 / {MOV CH, DL} + $88 / $E1 / {MOV CL, AH} + $81 / $E1 / $03 / $03 / {AND CX, 0303} + $41 / {INC CX} + $38 / $E9 / {CMP CL, CH} + $74 / $04 / {JZ Cont1:} + $08 / $E0 / {OR AL, AH} + $EB / $3E / {JMP OK:} + {Cont1:} + $D1 / $E0 / {SHL AX, 1} + $D1 / $E0 / {SHL AX, 1} + $F6 / $C4 / $01 / {TEST AH, 01} + $75 / $1E / {JNZ Cont2:} + $88 / $D5 / {MOV CH, DL} + $88 / $E1 / {MOV CL, AH} + $81 / $E1 / $03 / $03 / {AND CX, 0303} + $41 / {INC CX} + $38 / $E9 / {CMP CL, CH} + $74 / $11 / {JZ Cont2:} + $88 / $E2 / {MOV DL, AH} + $80 / $E2 / 03 / {AND DL, 03} + $D0 / $EC / {SHR AH, 1} + $D0 / $EC / {SHR AH, 1} + $D1 / $E8 / {SHR AX, 1} + $D1 / $E8 / {SHR AX, 1} + $08 / $D0 / {OR AL, DL} + $EB / $17 / {JMP OK:} + {Cont2:} + $88 / $D4 / {MOV AH, DL} + $B1 / $04 / {MOV CL, 04} + $D3 / $E8 / {SHR AX, CL} + $D0 / $E4 / {SHL AH, 1} + $D0 / $E4 / {SHL AH, 1} + $80 / $E2 / 03 / {AND DL, 03} + $08 / $D4 / {OR AH, DL} + $D1 / $E0 / {SHL AX, 1} + $D1 / $E0 / {SHL AX, 1} + $88 / $E0 / {MOV AL, AH} + $30 / $E4 / {XOR AH, AH} + {OK:} + $A2 / LRUMap / {MOV [LRUMap], AL} + $24 / $03 {AND AL, 03} + ); + + + Function OldestToNewest : Byte; + Inline ( + $A0 / LRUMap / {MOV AL, [LRUMap]} + $D0 / $C0 / {ROL AL, 1} + $D0 / $C0 / {ROL AL, 1} + $A2 / LRUMap / {MOV [LRUMap], AL} + $24 / $03 {AND AL, 03} + ); + + + Procedure ValueToNewest ( Value : Byte ); + + Begin + Inline ( + $8A / $9E / Value / {MOV BL, [BP+Value]} + $30 / $E4 / {XOR AH, AH} + $A0 / LRUMap / {MOV AL, [LRUMap]} + $89 / $C2 / {MOV DX, AX} + $24 / $03 / {AND AL, 03} + $38 / $D8 / {CMP AL, BL} + $74 / $3F / {JZ DoNothing:} + $89 / $D0 / {MOV AX, DX} + $D1 / $E0 / {SHL AX, 1} + $D1 / $E0 / {SHL AX, 1} + $38 / $DC / {CMP AH, BL} + $75 / $04 / {JNZ Cont1:} + $08 / $E0 / {OR AL, AH} + $EB / $2E / {JMP OK:} + {Cont1:} + $D1 / $E0 / {SHL AX, 1} + $D1 / $E0 / {SHL AX, 1} + $88 / $E1 / {MOV CL, AH} + $80 / $E1 / 03 / {AND CL, 03} + $38 / $D9 / {CMP CL, BL} + $75 / $0C / {JNZ Cont2:} + $D0 / $EC / {SHR AH, 1} + $D0 / $EC / {SHR AH, 1} + $D1 / $E8 / {SHR AX, 1} + $D1 / $E8 / {SHR AX, 1} + $08 / $C8 / {OR AL, CL} + $EB / $15 / {JMP OK:} + {Cont2:} + $88 / $D4 / {MOV AH, DL} + $B1 / $04 / {MOV CL, 04} + $D3 / $E8 / {SHR AX, CL} + $D0 / $E4 / {SHL AH, 1} + $D0 / $E4 / {SHL AH, 1} + $80 / $E2 / 03 / {AND DL, 03} + $08 / $D4 / {OR AH, DL} + $D1 / $E0 / {SHL AX, 1} + $D1 / $E0 / {SHL AX, 1} + $88 / $E0 / {MOV AL, AH} + {OK:} + $A2 / LRUMap {MOV [LRUMap], AL} + {DoNothing:} + ); + End; + + + Function AlreadyMapped ( Descr : Word ) : Byte; + Inline ( + $5B / {POP BX} + $31 / $C0 / {XOR AX, AX} + $3B / $1E / PhysPageDescr / {CMP BX, PhysPageDescr [0]} + $74 / $17 / {JZ OK:} + $40 / {INC AX} + $3B / $1E / PhysPageDescr + 2 / {CMP BX, PhysPageDescr [1]} + $74 / $10 / {JZ OK:} + $40 / {INC AX} + $3B / $1E / PhysPageDescr + 4 / {CMP BX, PhysPageDescr [2]} + $74 / $09 / {JZ OK:} + $40 / {INC AX} + $3B / $1E / PhysPageDescr + 6 / {CMP BX, PhysPageDescr [3]} + $74 / $02 / {JZ OK:} + $B0 / NotMapped {MOV AL, NotMapped} + {OK:} + ); + + + Function SmallOffset : Word; + Inline ( + $8A / $46 / < RealEMSPtr + 2 / {MOV AL, [BP+RealEMSPtr]} + $8A / $66 / < MapSmall / {MOV AH, [BP+MapSmall]} + $B1 / $06 / {MOV CL, 06} + $D3 / $E0 {SHL AX, CL} + ); + + + Function BigOffset : Word; + Inline ( + $31 / $C0 / {XOR AX, AX} + $8A / $66 / < MapBig / {MOV AH, [BP+MapBig]} + $D0 / $CC / {ROR AH, 1} + $D0 / $CC {ROR AH, 1} + ); + + + Procedure FourStepChange ( BigPos, SmallPos, TempPos : Byte ); + + Var + TempDescr : Word; + + Begin + If Not MapEMSPage ( HandleInfo [-1].Handle, 0, BigPos ) Then Begin + EMSHardError ( 146 ); + Exit; + End; + If Not MapEMSPage ( HandleInfo [Byte (PhysPageDescr [BigPos])].Handle, + PhysPageDescr [BigPos] Shr 8, SmallPos ) Then Begin + EMSHardError ( 146 ); + Exit; + End; + If Not MapEMSPage ( HandleInfo [Byte (PhysPageDescr [SmallPos])].Handle, + PhysPageDescr [SmallPos] Shr 8, TempPos ) Then Begin + EMSHardError ( 146 ); + Exit; + End; + If Not MapEMSPage ( HandleInfo [Byte (PhysPageDescr [TempPos])].Handle, + PhysPageDescr [TempPos] Shr 8, BigPos ) Then Begin + EMSHardError ( 146 ); + Exit; + End; + TempDescr := PhysPageDescr [BigPos]; + PhysPageDescr [BigPos] := PhysPageDescr [TempPos]; + PhysPageDescr [TempPos] := PhysPageDescr [SmallPos]; + PhysPageDescr [SmallPos] := TempDescr; + End; + + + Procedure ThreeStepChange ( MovePos, PivotPos : Byte ); + + Var + TempDescr : Word; + + Begin + If Not MapEMSPage ( HandleInfo [-1].Handle, 0, MovePos ) Then Begin + EMSHardError ( 146 ); + Exit; + End; + If Not MapEMSPage ( HandleInfo [Byte (PhysPageDescr [MovePos])].Handle, + PhysPageDescr [MovePos] Shr 8, PivotPos ) Then Begin + EMSHardError ( 146 ); + Exit; + End; + If Not MapEMSPage ( HandleInfo [Byte (PhysPageDescr [PivotPos])].Handle, + PhysPageDescr [PivotPos] Shr 8, MovePos ) Then Begin + EMSHardError ( 146 ); + Exit; + End; + TempDescr := PhysPageDescr [MovePos]; + PhysPageDescr [MovePos] := PhysPageDescr [PivotPos]; + PhysPageDescr [PivotPos] := TempDescr; + End; + + + Begin + {$IFNDEF NoErrorCheckEMSHeap} + If Not EMSHeapInitialized Then Begin + EMSHardError ( 50 ); + Exit; + End; + If HeapErrorFuncActive Then Begin + EMSHardError ( 60 ); + Exit; + End; + {$ENDIF} + {$IFDEF DebugEMSHeap} + If EPtr = Nil Then Begin + EMSHardError ( 150 ); + Exit; + End; + {$ENDIF} + With RealEMSPtr Do Begin + DescriptorSmall := (RealEMSPtr.LogPageOfs And $FF00) + Or TCEMSPtr (RealEMSPtr).HandleIndsLow; + MapSmall := AlreadyMapped ( DescriptorSmall ); + If MapSmall <> NotMapped Then Begin + {-Second part (small part) already mapped to MapSmall} + If (HandleInds And $FF00) <> 0 Then Begin + {-Two pages} + DescriptorBig := (HandleInds Shr 8) Or (LogPageOfs Shl 8); + MapBig := AlreadyMapped ( DescriptorBig ); + If MapBig <> NotMapped Then Begin + {-First part (big part) already mapped to MapBig} + If Odd (MapBig) Then Begin + {-Both parts mapped, but first part must be on an even + position followed by the second} + If MapBig = 1 Then Begin + Case MapSmall Of + 0 : Begin + ThreeStepChange ( 1, 0 ); + MapBig := 0; + End; + 2 : Begin + FourStepChange ( 1, 0, 2 ); + MapBig := 0; + End; + 3 : Begin + ThreeStepChange ( 1, 2 ); + MapBig := 2; + End; + End; {Case} + End Else Begin + {-MapBig is 3} + Case MapSmall Of + 0 : Begin + FourStepChange ( 3, 0, 1 ); + MapBig := 0; + End; + 1 : Begin + ThreeStepChange ( 3, 0 ); + MapBig := 0; + End; + 2 : Begin + ThreeStepChange ( 3, 2 ); + MapBig := 2; + End; + End; {Case} + End; + MapSmall := Succ (MapBig); + End Else Begin + If Succ (MapBig) <> MapSmall Then Begin + {-Both parts mapped, but second part must follow first; + avoid mapping one page two times at the same time} + If MapBig = 0 Then Begin + Case MapSmall Of + 2 : Begin + ThreeStepChange ( 2, 1 ); + End; + 3 : Begin + ThreeStepChange ( 3, 1 ); + End; + End; {Case} + End Else Begin + {-MapBig is 2} + Case MapSmall Of + 0 : Begin + FourStepChange ( 2, 0, 1 ); + MapBig := 0; + End; + 1 : Begin + ThreeStepChange ( 2, 0 ); + MapBig := 0; + End; + End; {Case} + End; + MapSmall := Succ (MapBig); + End; + End; + ValueToNewest ( MapBig ); + ValueToNewest ( MapSmall ); + MapEMSPtr := Ptr ( FramePtrSeg, BigOffset ); + End Else Begin + {-First part (big part) not mapped yet} + If Odd (MapSmall) Then Begin + {-OK, first part (big part) can be mapped underneath} + MapBig := Pred (MapSmall); + If Not MapEMSPage ( HandleInfo [Byte (DescriptorBig)].Handle, + DescriptorBig Shr 8, MapBig ) Then Begin + EMSHardError ( 140 ); + Exit; + End; + ValueToNewest ( MapBig ); + PhysPageDescr [MapBig] := DescriptorBig; + ValueToNewest ( MapSmall ); + PhysPageDescr [MapSmall] := DescriptorSmall; + MapEMSPtr := Ptr ( FramePtrSeg, BigOffset ); + End Else Begin + {-Solve problem, and map first part (big part) to MapSmall on + an even page number, and map second part (small part) above} + MapBig := MapSmall; + If Not MapEMSPage ( HandleInfo [Byte (DescriptorBig)].Handle, + DescriptorBig Shr 8, MapBig ) Then Begin + EMSHardError ( 141 ); + Exit; + End; + ValueToNewest ( MapBig ); + PhysPageDescr [MapBig] := DescriptorBig; + MapSmall := Succ (MapBig); + If Not MapEMSPage ( HandleInfo [Byte (DescriptorSmall)].Handle, + DescriptorSmall Shr 8, MapSmall ) Then Begin + EMSHardError ( 142 ); + Exit; + End; + ValueToNewest ( MapSmall ); + PhysPageDescr [MapSmall] := DescriptorSmall; + MapEMSPtr := Ptr ( FramePtrSeg, BigOffset ); + End; + End; + End Else Begin + {-Only one page, and already mapped} + ValueToNewest ( MapSmall ); + MapEMSPtr := Ptr ( FramePtrSeg, SmallOffset ); + End; + End Else Begin + {-Second part not mapped yet} + If (HandleInds And $FF00) <> 0 Then Begin + {-Two pages} + DescriptorBig := (HandleInds Shr 8) Or (LogPageOfs Shl 8); + MapBig := AlreadyMapped ( DescriptorBig ); + If MapBig <> NotMapped Then Begin + {-First part (big part) already mapped} + If Odd (MapBig) Then Begin + {-First part misplaced, correct this} + If Not MapEMSPage ( HandleInfo [-1].Handle, 0, MapBig ) + Then Begin + EMSHardError ( 147 ); + Exit; + End; + Dec (MapBig); + {-Make it even} + If Not MapEMSPage ( HandleInfo [Byte (DescriptorBig)].Handle, + DescriptorBig Shr 8, MapBig ) Then Begin + EMSHardError ( 148 ); + Exit; + End; + PhysPageDescr [MapBig] := DescriptorBig; + End; + ValueToNewest ( MapBig ); + {-Make it the newest} + End Else Begin + {-Map first part (big part)} + MapBig := EvenToNewest; + If Not MapEMSPage ( HandleInfo [Byte (DescriptorBig)].Handle, + DescriptorBig Shr 8, MapBig ) Then Begin + EMSHardError ( 143 ); + Exit; + End; + PhysPageDescr [MapBig] := DescriptorBig; + End; + MapSmall := Succ (MapBig); + If Not MapEMSPage ( HandleInfo [Byte (DescriptorSmall)].Handle, + DescriptorSmall Shr 8, MapSmall ) Then Begin + EMSHardError ( 144 ); + Exit; + End; + ValueToNewest ( MapSmall ); + PhysPageDescr [MapSmall] := DescriptorSmall; + MapEMSPtr := Ptr ( FramePtrSeg, BigOffset ); + End Else Begin + {-Only one page} + MapSmall := OldestToNewest; + If Not MapEMSPage ( HandleInfo [Byte (DescriptorSmall)].Handle, + DescriptorSmall Shr 8, MapSmall ) Then Begin + EMSHardError ( 145 ); + Exit; + End; + PhysPageDescr [MapSmall] := DescriptorSmall; + MapEMSPtr := Ptr ( FramePtrSeg, SmallOffset ); + End; + End; + End; + End; + + + Function SaveEMSCtxt : Byte; + + Var + W : Word; + + Begin + SaveEMSCtxt := 255; + {$IFNDEF NoErrorCheckEMSHeap} + If Not EMSHeapInitialized Then Begin + EMSHardError ( 50 ); + Exit; + End; + {$ENDIF} + For W := 1 To HandlesToUseForAlloc Do Begin + With HandleInfo [W] Do Begin + If Not UsedForSave Then Begin + If SaveEMSContext ( Handle ) Then Begin + SaveEMSCtxt := W; + End Else Begin + EMSHardError ( 110 ); + End; + UsedForSave := True; + PhPgDescr := PhysPageDescr; + LRU := LRUMap; + Exit; + End; + End; + End; + EMSHardError ( 111 ); + End; + + + Procedure RestoreEMSCtxt ( HandleInd : Byte ); + + Begin + {$IFNDEF NoErrorCheckEMSHeap} + If Not EMSHeapInitialized Then Begin + EMSHardError ( 50 ); + Exit; + End; + {$ENDIF} + With HandleInfo [HandleInd] Do Begin + If Not RestoreEMSContext ( Handle ) Then Begin + EMSHardError ( 112 ); + Exit; + End; + UsedForSave := False; + PhysPageDescr := PhPgDescr; + LRUMap := LRU; + End; + End; + + + Procedure FindNextHole ( Var Size, FreeLInd : Word; OffsetZero : Boolean ); + {-FreeList must be mapped on call} + Var + W, + BlockSize, + FoundSize : Word; + + Begin + If FreeLInd >= UsedNrOfFreeListEntries Then Begin + FreeLInd := 0; + Exit; + End; + W := FreeLInd; + If (Size And $003F) <> 0 Then Begin + BlockSize := ((Size + $0040) And $FFC0) Shr 6; + End Else Begin + BlockSize := Size Shr 6; + End; + If BlockSize > 0 Then Dec (BlockSize); + {-Set BlockSize to granulity and adjust to LenM1} + Repeat + Inline ( + $C4 / $3E / FramePtr / {LES DI, [FramePtr]} + $83 / $C7 / $02 / {ADD DI, 02} + $8B / $86 / W / {MOV AX, [BP+W]} + $8B / $0E / UsedNrOfFreeListEntries / {MOV CX, [UsedNrOf..]} + $89 / $CB / {MOV BX, CX} + $29 / $C1 / {SUB CX, AX} + $76 / $16 / {JBE EndLoop:} + $D1 / $E0 / {SHL AX, 1} + $D1 / $E0 / {SHL AX, 1} + $01 / $C7 / {ADD DI, AX} + $8A / $96 / BlockSize / {MOV DL, [BP+BlockSize]} + {Scan:} + $26 / $8B / $05 / {MOV AX, ES:[DI]} + $38 / $D0 / {CMP AL, DL} + $73 / $05 / {JNB EndLoop:} + $83 / $C7 / $04 / {ADD DI, 04} + $E2 / $F4 / {LOOP Scan:} + {EndLoop:} + $29 / $CB / {SUB BX, CX} + $43 / {INC BX} + $89 / $9E / W / {MOV [BP+W], BX} + $25 / $FF / $00 / {AND AX, 00FF} + $40 / {INC AX} + $89 / $86 / FoundSize {MOV [BP+FoundSize], AX} + ); + If W > UsedNrOfFreeListEntries Then Begin + FreeLInd := 0; + Exit; + End; + If Not OffsetZero + Or ((FreeList (FramePtr^) [W].Offset And $00FF) = 0) Then Begin + Size := FoundSize Shl 6; + FreeLInd := W; + Exit; + End; + Until False; + End; + + + Procedure GetEMSMem ( Var EPtr : EMSPointer; Size : Word ); + + Var + FreeLInd1, + FreeLInd2 : Word; + RepeatIt : Boolean; + + + Procedure BuildPointerAdjFreeList ( Size, + FreeLInd1, + FreeLInd2 : Word; + Var EPtr : EMSPointer ); + {-FreeList must be mapped on call} + Var + RealEMSPtr : RealEMSPointer Absolute EPtr; + UsedBlks : Word; + + Begin + With RealEMSPtr Do Begin + If Size > PhysPageSize Then Begin + With FreeList (FramePtr^) [FreeLInd2] Do Begin + HandleInds := Word (HandleIndex) Shl 8; + LogPageOfs := Offset Shr 8; + {-Set big part of pointer} + End; + If FreeLInd1 = UsedNrOfFreeListEntries Then FreeLInd1 := FreeLInd2; + {-Correct following movement of entry FreeLInd1} + FreeList (FramePtr^) [FreeLInd2] := + FreeList (FramePtr^) [UsedNrOfFreeListEntries]; + Dec (UsedNrOfFreeListEntries); + UsedBlks := (Size - PhysPageSize) Shr 6; + With FreeList (FramePtr^) [FreeLInd1] Do Begin + HandleInds := HandleInds Or HandleIndex; + LogPageOfs := LogPageOfs Or (Offset And $FF00); + {-Set small part of pointer} + If UsedBlks > LenM1 Then Begin + FreeList (FramePtr^) [FreeLInd1] := + FreeList (FramePtr^) [UsedNrOfFreeListEntries]; + Dec (UsedNrOfFreeListEntries); + End Else Begin + Dec (LenM1, UsedBlks); + Inc (Offset, UsedBlks); + End; + End; + End Else Begin + With FreeList (FramePtr^) [FreeLInd1] Do Begin + HandleInds := HandleIndex; + UsedBlks := Size Shr 6; + LogPageOfs := Offset + Succ (Word (LenM1)) - UsedBlks; + {-Take end of hole} + If UsedBlks > LenM1 Then Begin + FreeList (FramePtr^) [FreeLInd1] := + FreeList (FramePtr^) [UsedNrOfFreeListEntries]; + Dec (UsedNrOfFreeListEntries); + End Else Begin + Dec (LenM1, UsedBlks); + End; + End; + End; + End; + End; + + + Procedure FindFreeListEntries ( Size : Word; + Var FreeLInd1, + FreeLInd2 : Word ); + {-FreeList must be mapped on call; Size must be <= 32768; + FreeLInd1 = 0 on return indicates nothing found} + Var + SaveSize, + FirstSize, + RestSize : Word; + + Begin + FreeLInd1 := 0; + FreeLInd2 := 0; + If Size > PhysPageSize Then Begin + RestSize := Size - PhysPageSize; + FirstSize := PhysPageSize; + End Else Begin + RestSize := 0; + FirstSize := Size; + End; + FindNextHole ( FirstSize, FreeLInd1, False ); + If FreeLInd1 = 0 Then Exit; + {-No hole found} + If RestSize > 0 Then Begin + FreeLInd2 := FreeLInd1; + FreeLInd1 := 0; + SaveSize := RestSize; + FindNextHole ( RestSize, FreeLInd1, True ); + If FreeLInd1 = FreeLInd2 Then Begin + FindNextHole ( SaveSize, FreeLInd1, True ); + End; + End; + End; + + + Begin + EPtr := Nil; + {$IFNDEF NoErrorCheckEMSHeap} + If Not EMSHeapInitialized Then Begin + EMSHardError ( 50 ); + Exit; + End; + If Size > MaxEMSAllocSize Then Begin + EMSHardError ( 120 ); + Exit; + End; + {$ENDIF} + If Size = 0 Then Exit; + If (Size And $003F) <> 0 Then Begin + Size := (Size + $0040) And $FFC0; + {-Adjust Size to granulity} + End; + If Not MapFreeList Then Exit; + Repeat + RepeatIt := False; + FindFreeListEntries ( Size, FreeLInd1, FreeLInd2 ); + If FreeLInd1 = 0 Then Begin + Case EMSHeapError ( Size ) Of + 0 : Begin + EMSHardError ( 121 ); + End; + 1 :; + 2 : Begin + RepeatIt := True; + End; + End; {Case} + End Else Begin + BuildPointerAdjFreeList ( Size, FreeLInd1, FreeLInd2, EPtr ); + End; + Until Not RepeatIt; + UnmapFreeList; + End; + + + Procedure FreeEMSMem ( EPtr : EMSPointer; Size : Word ); + + Var + RealEMSPtr : RealEMSPointer Absolute EPtr; + UpperBindFreeLInd, + UpperHoleStart, + RealOfs, + BlockSize : Word; + Binded : Boolean; + + + Function IncUsedNrOfFreeListEntries : Boolean; + + Begin + If UsedNrOfFreeListEntries >= NrOfFreeListEntries Then Begin + IncUsedNrOfFreeListEntries := False; + End Else Begin + IncUsedNrOfFreeListEntries := True; + Inc (UsedNrOfFreeListEntries); + End; + End; + + + Procedure FindFreeBinder ( Var FLBinderInd : Word; + HandleInd, + LogPage, + StartStop : Byte; + AddLen : Boolean ); + + Var + W : Word; + + Begin + FLBinderInd := 0; + If UsedNrOfFreeListEntries = 0 Then Exit; + Inline ( + $C4 / $3E / FramePtr / {LES DI, [FramePtr]} + $8B / $0E / UsedNrOfFreeListEntries / {MOV CX, [UsedNrOf..]} + $8A / $96 / HandleInd / {MOV DL, [BP+HandleInd]} + $8A / $B6 / LogPage / {MOV DH, [BP+LogPage]} + $8A / $9E / StartStop / {MOV BL, [BP+StartStop]} + $8A / $BE / AddLen / {MOV BH, [BP+AddLen]} + {Scan:} + $26 / $3A / $55 / $03 / {CMP DL, ES:[DI+3]} + $75 / $17 / {JNZ Search:} + $26 / $3A / $75 / $01 / {CMP DH, ES:[DI+1]} + $75 / $11 / {JNZ Search:} + $26 / $8A / $05 / {MOV AL, ES:[DI]} + $08 / $FF / {OR BH, BH} + $74 / $06 / {JZ NoAddLen:} + $26 / $02 / $45 / $02 / {ADD AL, ES:[DI+2]} + $FE / $C0 / {INC AL} + {NoAddLen:} + $38 / $D8 / {CMP AL, BL} + $74 / $05 / {JZ EndLoop:} + $83 / $C7 / $04 / {ADD DI, 04} + $E2 / $DE / {LOOP Scan:} + {EndLoop:} + $8B / $1E / UsedNrOfFreeListEntries / {MOV BX, [UsedNrOf..]} + $29 / $CB / {SUB BX, CX} + $43 / {INC BX} + $89 / $9E / W {MOV [BP+W], BX} + ); + If W <= UsedNrOfFreeListEntries Then Begin + FLBinderInd := W; + End; + + End; + + + Function TryToBindUpperHole ( HandleInd, + LogPage, + Len, + StartNew : Byte; + Var UpperBindFreeLInd : Word ) : Boolean; + + Var + FLBinderInd : Word; + + Begin + TryToBindUpperHole := False; + UpperBindFreeLInd := 0; + FindFreeBinder ( FLBinderInd, HandleInd, LogPage, StartNew, False ); + If FLBinderInd <> 0 Then Begin + With FreeList (FramePtr^) [FLBinderInd] Do Begin + Inc (LenM1, Len); + Dec (Offset, Len); + UpperBindFreeLInd := FLBinderInd; + TryToBindUpperHole := True; + End; + End; + End; + + + Function TryToBindLowerHole ( HandleInd, + LogPage, + Len, + Finish : Byte; + UpperBindFreeLInd : Word ) : Boolean; + + Var + FLBinderInd : Word; + + Begin + TryToBindLowerHole := False; + FindFreeBinder ( FLBinderInd, HandleInd, LogPage, Finish, True ); + If FLBinderInd <> 0 Then Begin + With FreeList (FramePtr^) [FLBinderInd] Do Begin + If UpperBindFreeLInd = 0 Then Begin + Inc (LenM1, Len); + End Else Begin + Inc (LenM1, Succ (FreeList (FramePtr^) [UpperBindFreeLInd].LenM1)); + FreeList (FramePtr^) [UpperBindFreeLInd] := + FreeList (FramePtr^) [UsedNrOfFreeListEntries]; + Dec (UsedNrOfFreeListEntries); + End; + TryToBindLowerHole := True; + End; + End; + End; + + + Begin + {$IFNDEF NoErrorCheckEMSHeap} + If Not EMSHeapInitialized Then Begin + EMSHardError ( 50 ); + Exit; + End; + If EPtr = Nil Then Begin + EMSHardError ( 130 ); + Exit; + End; + If Size > MaxEMSAllocSize Then Begin + EMSHardError ( 120 ); + Exit; + End; + {$ENDIF} + If Size = 0 Then Exit; + If Not MapFreeList Then Exit; + If Size > PhysPageSize Then Begin + With RealEMSPtr Do Begin + {$IFNDEF NoErrorCheckEMSHeap} + If (HandleInds And $FF00) = 0 Then Begin + EMSHardError ( 131 ); + UnmapFreeList; + Exit; + End; + {$ENDIF} + If IncUsedNrOfFreeListEntries Then Begin + With FreeList (FramePtr^) [UsedNrOfFreeListEntries] Do Begin + HandleIndex := Byte (HandleInds Shr 8); + Offset := (LogPageOfs And $00FF) Shl 8; + LenM1 := $FF; + End; + End Else Begin + UnmapFreeList; + Exit; + End; + HandleInds := HandleInds And $00FF; + LogPageOfs := LogPageOfs And $FF00; + Dec (Size, PhysPageSize); + {-Simulate a size <= 16384} + End; + End; + If (RealEMSPtr.HandleInds And $FF00) <> 0 Then Begin + EMSHardError ( 132 ); + Exit; + End; + BlockSize := Size Shr 6; + If (Size And $003F) <> 0 Then Inc (BlockSize); + RealOfs := RealEMSPtr.LogPageOfs And $00FF; + UpperHoleStart := RealOfs + BlockSize; + {-Calculate upper hole start} + Binded := False; + UpperBindFreeLInd := 0; + If UpperHoleStart < (PhysPageSize Shr 6) Then Begin + With RealEMSPtr Do Begin + Binded := TryToBindUpperHole ( HandleInds, Byte (LogPageOfs Shr 8), + BlockSize, UpperHoleStart, UpperBindFreeLInd ); + End; + End; + If RealOfs > 0 Then Begin + With RealEMSPtr Do Begin + If TryToBindLowerHole ( HandleInds, Byte (LogPageOfs Shr 8), + BlockSize, RealOfs, UpperBindFreeLInd ) Then Binded := True; + End; + End; + If Not Binded Then Begin + If IncUsedNrOfFreeListEntries Then Begin + With FreeList (FramePtr^) [UsedNrOfFreeListEntries], RealEMSPtr + Do Begin + HandleIndex := Byte (HandleInds); + Offset := LogPageOfs; + LenM1 := Byte (Pred (BlockSize)); + End; + End; + End; + UnmapFreeList; + End; + + + Function EMSMemAvail : LongInt; + + Var + W : Word; + Avail : LongInt; + + Begin + EMSMemAvail := 0; + {$IFNDEF NoErrorCheckEMSHeap} + If Not EMSHeapInitialized Then Begin + EMSHardError ( 50 ); + Exit; + End; + {$ENDIF} + If Not MapFreeList Then Exit; + Avail := 0; + For W := 1 To UsedNrOfFreeListEntries Do Begin + Inc (Avail, (Succ (Word (FreeList (FramePtr^) [W].LenM1))) Shl 6); + End; + EMSMemAvail := Avail; + UnmapFreeList; + End; + + + Function EMSMaxAvail : Word; + + Var + OldAvail, + Avail, + FLInd, + FirstPageInd : Word; + + Begin + EMSMaxAvail := 0; + {$IFNDEF NoErrorCheckEMSHeap} + If Not EMSHeapInitialized Then Begin + EMSHardError ( 50 ); + Exit; + End; + {$ENDIF} + If Not MapFreeList Then Exit; + Avail := 0; + FLInd := 0; + Repeat + OldAvail := Avail; + Inc (Avail, 64); + FindNextHole ( Avail, FLInd, False ); + Until (Avail = PhysPageSize) Or (FLInd = 0); + If FLInd = 0 Then Avail := OldAvail; + If (Avail < PhysPageSize) Then Begin + EMSMaxAvail := Avail; + UnmapFreeList; + Exit; + End; + FirstPageInd := FLInd; + Avail := 0; + FLInd := 0; + Repeat + OldAvail := Avail; + Inc (Avail, 64); + FindNextHole ( Avail, FLInd, True ); + If FLInd = FirstPageInd Then Avail := OldAvail; + Until ((Avail = PhysPageSize) Or (FLInd = 0)); + If (Avail <> PhysPageSize) Or (FLInd = 0) Then Avail := OldAvail; + EMSMaxAvail := Avail + PhysPageSize; + UnmapFreeList; + End; + + + Var + SaveExitProc : Pointer; + +{$IFDEF XXFPlusOptXX} + {$UNDEF XXFPlusOptXX} +{$ENDIF} +{$IFOPT F+} + {$DEFINE XXFPlusOptXX} +{$ENDIF} +{$F+} + Procedure EMSHeapExitProc; + + Begin + ExitProc := SaveExitProc; + If EMSHeapInitialized Then Begin + DeAlloc ( HandlesToUseForAlloc ); + End; + EMSHeapInitialized := False; + End; +{$IFNDEF XXFPlusOptXX} + {$F-} +{$ELSE} + {$UNDEF XXFPlusOptXX} +{$ENDIF} + + + Procedure PerformEMSHeapInit ( FreePages : Word ); + + Begin + EMSHeapInitialized := DoInit ( FreePages ); + End; + + + Procedure InitEMSHeap ( FreePages : Word ); + + Begin + {$IFDEF ManualInitEMSHeap} + If EMSHeapInitialized Then Begin + EMSHardError ( 75 ); + End Else Begin + PerformEMSHeapInit ( FreePages ); + End; + {$ELSE} + EMSHardError ( 70 ); + {$ENDIF} + End; + + + Procedure ExitEMSHeap; + + Begin + {$IFDEF ManualInitEMSHeap} + If EMSHeapInitialized Then Begin + DeAlloc ( HandlesToUseForAlloc ); {!!.41} + EMSHeapInitialized := False; {!!.41} + End; + {$ELSE} + EMSHardError ( 80 ); + {$ENDIF} + End; + + +Begin + EMSHeapInitialized := False; + SaveExitProc := ExitProc; + ExitProc := @EMSHeapExitProc; +{$IFNDEF ManualInitEMSHeap} + PerformEMSHeapInit ( ToLetFreePages ); +{$ENDIF} +End. diff --git a/src/wc_sdk/emssupp.pas b/src/wc_sdk/emssupp.pas new file mode 100644 index 0000000..790aa20 --- /dev/null +++ b/src/wc_sdk/emssupp.pas @@ -0,0 +1,245 @@ +{********************************************************************} +{* EMSHEAP.PAS - EMS support routines *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$IFDEF CanAllowOverlays} + {$O+,F+} + {$ENDIF} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + + +Unit EMSSupp; + +Interface + +Uses + BaseSupp; + +Const + EMSErrorCode = $0FFFF; + + + Function AllocateEMSPages ( NrOfPages : Word ) : Word; + + Function DeAllocateEMSHandle ( Handle : Word ) : Boolean; + + Function EMSInstalled : Boolean; + +{$IFNDEF DPMIOrWnd} + Function EmmSigFound : Boolean; +{$ENDIF} + + Function EMSVersion : Byte; + + Function EMSPageFramePtr : Pointer; + + Function EMSPagesAvail : Word; + + Function MapEMSPage ( Handle, LogPage : Word; PhysPage : Byte ): Boolean; + Inline ( + $58 / $5B / $5A / {pop ax, bx, dx} + $B4 / $44 / {mov ah, $44 = mappage} + $CD / $67 / {int $67 = ems} + $08 / $E4 / {or ah, ah} + $B8 / $01 / $00 / {mov ax, $01} + $74 / $01 / {jz ok} + $48 ); {dec ax} + {ok:} + + Function SaveEmsContext ( Handle : Word ) : Boolean; Inline ( + $5A / {pop dx} + $B4 / $47 / {mov ah, $47 = savecont} + $CD / $67 / {int $67 = ems} + $08 / $E4 / {or ah, ah} + $B8 / $01 / $00 / {mov ax, $01} + $74 / $01 / {jz ok} + $48 ); {dec ax} + {ok:} + + Function RestoreEmsContext ( Handle : Word ) : Boolean; Inline ( + $5A / {pop dx} + $B4 / $48 / {mov ah, $47 = restcont} + $CD / $67 / {int $67 = ems} + $08 / $E4 / {or ah, ah} + $B8 / $01 / $00 / {mov ax, $01} + $74 / $01 / {jz ok} + $48 ); {dec ax} + {ok:} + + +Implementation + +Const + EMSInterrupt = $67; + DPMIInterrupt = $31; + + + Function AllocateEMSPages ( NrOfPages : Word ) : Word; + + Var + EMSRegs : GenRegisters; + + Begin + DefaultRegisters ( EMSRegs ); + With EMSRegs Do Begin + AH := $43; + BX := NrOfPages; + CallIntr ( EMSInterrupt, EMSRegs ); + If AH = 0 Then Begin + AllocateEMSPages := DX; + End Else Begin + AllocateEMSPages := EMSErrorCode; + End; + End; + End; + + + Function DeAllocateEMSHandle ( Handle : Word ) : Boolean; + + Var + EMSRegs : GenRegisters; + + Begin + DefaultRegisters ( EMSRegs ); + With EMSRegs Do Begin + AH := $45; + DX := Handle; + CallIntr ( EMSInterrupt, EMSRegs ); + DeAllocateEMSHandle := AH = 0; + End; + End; + + + Function EMSInstalled : Boolean; + + Var + F : File; + Dummy : Integer; + + Begin + EmsInstalled := False; + Assign ( F, 'EMMXXXX0' ); + Reset ( F ); + If IOResult = 0 Then Begin + EmsInstalled := True; + Close ( F ); + Dummy := IOResult; + End; + End; + + +{$IFNDEF DPMIOrWnd} + Function EmmSigFound : Boolean; + + Type + NameArr = Array [1..8] Of Char; + + Const + EMMName : NameArr = 'EMMXXXX0'; + + Var + EMMIntPtr : Pointer Absolute $0000:$019C; + + Begin + If EMMIntPtr = Nil Then Begin + EmmSigFound := False; + End Else Begin + EmmSigFound := EMMName = NameArr (Ptr ( Seg (EMMIntPtr^), $0A )^); + End; + End; +{$ENDIF} + + + Function EMSVersion : Byte; + + Var + EMSRegs : GenRegisters; + + Begin + DefaultRegisters ( EMSRegs ); + With EMSRegs Do Begin + AH := $46; + CallIntr ( EMSInterrupt, EMSRegs ); + If AH = 0 Then Begin + EMSVersion := AL; + End Else Begin + EMSVersion := 0; + End; + End; + End; + + + Function EMSPageFramePtr : Pointer; + + Var + EMSRegs : GenRegisters; + + Begin + DefaultRegisters ( EMSRegs ); + With EMSRegs Do Begin + AH := $41; + CallIntr ( EMSInterrupt, EMSRegs ); + If AH = 0 Then Begin + EMSPageFramePtr := Ptr ( BX, 0 ); + End Else Begin + EMSPageFramePtr := Nil; + End; + End; + End; + + + Function EMSPagesAvail : Word; + + Var + EMSRegs : GenRegisters; + + Begin + DefaultRegisters ( EMSRegs ); + With EMSRegs Do Begin + AH := $42; + CallIntr ( EMSInterrupt, EMSRegs ); + If AH = 0 Then Begin + EMSPagesAvail := BX; + End Else Begin + EMSPagesAvail := EMSErrorCode; + End; + End; + End; + + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/example.pas b/src/wc_sdk/example.pas new file mode 100644 index 0000000..3a6a857 --- /dev/null +++ b/src/wc_sdk/example.pas @@ -0,0 +1,356 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +program Example; + {-Example calls for basic database operations} + +uses + Filer; + +type + PersonDef = + record + Del : LongInt; + FirstName : String[20]; + LastName : String[25]; + Street : String[30]; + City : String[30]; + State : String[2]; + ZipCode : String[9]; + Telephone : String[15]; + Age : Integer; + end; + +var + PF : IsamFileBlockPtr; {Symbolic access to the database} + +const + Key1Len = 30; {First and last name} + Key2Len = 5; {ZipCode} + Key3Len = 15; {Telephone} + + APerson : PersonDef = + (Del : 0; + FirstName : 'George'; + LastName : 'Bush'; + Street : '1 Capitol Ave'; + City : 'Washington'; + State : 'DC'; + ZipCode : '10011-0001'; + Telephone : '301-222-1111'; + Age : 64); + + procedure AllocatePageBuffer(HeapToRemain : LongInt); + var + NumberOfPages : Word; + begin + NumberOfPages := BTInitIsam(NoNet, HeapToRemain, 0); + if not IsamOK then begin + {Insufficient memory} + Halt; + end; + end; + + function CreateFile : Boolean; + var + IID : IsamIndDescr; + begin + IID[1].KeyL := Key1Len; IID[1].AllowDupK := False; + IID[2].KeyL := Key2Len; IID[2].AllowDupK := True; + IID[3].KeyL := Key3Len; IID[3].AllowDupK := True; + BTCreateFileBlock('TEST', SizeOf(PersonDef), 3, IID); + CreateFile := IsamOK; + end; + + function OpenFile : Boolean; + begin + BTOpenFileBlock(PF, 'TEST', False, False, False, False); + if not IsamOK then begin + OpenFile := False; + {Error reporting code that examines + can go here. Corrective action may + be taken, for example by reconstructing a defective + index file as described in Section 6.D.} + Exit; + end else + OpenFile := True; + end; + + function CloseFile : Boolean; + begin + BTCloseFileBlock(PF); + if not IsamOK then begin + CloseFile := False; + {Error handling} + Exit; + end else + CloseFile := True; + end; + + function StUpcase(S : String) : String; + var + I : Integer; + begin + for I := 1 to Length(S) do + S[I] := Upcase(S[I]); + StUpcase := S; + end; + + function Pad(S : String; Len : Byte) : String; + var + SLen : Byte absolute S; + begin + if SLen > Len then + SLen := Len + else + while SLen < Len do + S := S+' '; + Pad := S; + end; + + {$F+} {Routine should be global} + function CreateKey(var P; KeyNr : Integer) : IsamKeyStr; + begin + with PersonDef(P) do + case KeyNr of + 1 : CreateKey := StUpcase(Pad(LastName, 20)+Pad(FirstName, 10)); + 2 : CreateKey := Copy(ZipCode, 1, 5); + 3 : CreateKey := Copy(Telephone, 1, 15); + else + CreateKey := ''; + end; + end; + + procedure UndoAdd(P : PersonDef; RefNr : LongInt; LastKey : Integer); + var + KeyNr : Integer; + Key : IsamKeyStr; + begin + for KeyNr := 1 to LastKey do begin + Key := CreateKey(P, KeyNr); + BTDeleteKey(PF, KeyNr, RefNr, Key); + if not IsamOK then + {Abort: too many errors} + Halt; + end; + end; + + function AddRecord(P : PersonDef) : Boolean; + var + KeyNr : Integer; + RefNr : LongInt; + Key : IsamKeyStr; + begin + AddRecord := False; + BTAddRec(PF, RefNr, P); + if not IsamOK then begin + {Error handling} + Exit; + end; + for KeyNr := 1 to BTNrOfKeys(PF) do begin + Key := CreateKey(P, KeyNr); + BTAddKey(PF, KeyNr, RefNr, Key); + if not IsamOK then begin + {Remove keys added so far} + UndoAdd(P, RefNr, KeyNr-1); + {Remove the new record} + BTDeleteRec(PF, RefNr); + {Error handling} + Exit; + end; + end; + AddRecord := True; + end; + + procedure UndoDel(P : PersonDef; RefNr : LongInt; LastKey : Integer); + var + KeyNr : Integer; + Key : IsamKeyStr; + begin + for KeyNr := 1 to LastKey do begin + Key := CreateKey(P, KeyNr); + BTAddKey(PF, KeyNr, RefNr, Key); + if not IsamOK then + {Abort: too many errors} + Halt; + end; + end; + + function DeleteRecord(P : PersonDef; RefNr : LongInt) : Boolean; + var + KeyNr : Integer; + Key : IsamKeyStr; + begin + DeleteRecord := False; + {Assure record not already deleted} + if P.Del <> 0 then + Exit; + for KeyNr := 1 to BTNrOfKeys(PF) do begin + Key := CreateKey(P, KeyNr); + BTDeleteKey(PF, KeyNr, RefNr, Key); + if not IsamOK then begin + {Add keys that have been deleted so far} + UndoDel(P, RefNr, KeyNr-1); + {Error handling} + Exit; + end; + end; + BTDeleteRec(PF, RefNr); + if IsamOK then + DeleteRecord := True; + end; + + function CheckRecord(P, POld : PersonDef) : Boolean; + begin + {Verify that: new record has valid keys, + new record differs from old} + CheckRecord := True; + end; + + function ModifyRecord(P, POld : PersonDef; RefNr : LongInt) : Boolean; + var + KeyNr : Integer; + begin + ModifyRecord := False; + if not CheckRecord(P, POld) then + Exit; + for KeyNr := 1 to BTNrOfKeys(PF) do begin + {Update modified keys} + if CreateKey(P, KeyNr) <> CreateKey(POld, KeyNr) then begin + BTDeleteKey(PF, KeyNr, RefNr, CreateKey(POld, KeyNr)); + if not IsamOK then + if IsamError = 10220 then + {Key already deleted, ignore the error} + else begin + UndoAdd(P, RefNr, KeyNr-1); + UndoDel(POld, RefNr, KeyNr-1); + Exit; + end; + BTAddKey(PF, KeyNr, RefNr, CreateKey(P, KeyNr)); + if not IsamOK then begin + UndoAdd(P, RefNr, KeyNr-1); + UndoDel(POld, RefNr, KeyNr); + Exit; + end; + end; + end; + + BTPutRec(PF, RefNr, P, False); + if not IsamOK then begin + UndoAdd(P, RefNr, BTNrOfKeys(PF)); + UndoDel(POld, RefNr, BTNrOfKeys(PF)); + Exit; + end; + + ModifyRecord := True; + end; + + function NextPrevRecord(var P : PersonDef; + var RefNr : LongInt; + KeyNr : Integer; + var Key : IsamKeyStr; + Next : Boolean) : Boolean; + begin + NextPrevRecord := False; + if Next then begin + BTNextKey(PF, KeyNr, RefNr, Key); + if not IsamOK and (IsamError = 10250) then + {There was no next key. Move to first key in the file} + BTNextKey(PF, KeyNr, RefNr, Key); + end else begin + BTPrevKey(PF, KeyNr, RefNr, Key); + if not IsamOK and (IsamError = 10260) then + {There was no previous key. Move to last key in file} + BTPrevKey(PF, KeyNr, RefNr, Key); + end; + if not IsamOK then + Exit; + BTGetRec(PF, RefNr, P, False); + if not IsamOK then begin + {Error handling} + Exit; + end; + NextPrevRecord := True; + end; + + function FindRecord(var P : PersonDef; + var RefNr : LongInt; + KeyNr : Integer; + var Key : IsamKeyStr) : Boolean; + begin + FindRecord := False; + BTSearchKey(PF, KeyNr, RefNr, Key); + if not IsamOK then begin + {Determine why SearchKey failed, for example: + IsamError = 10210 Neither the key nor any larger was found.} + Exit; + end; + BTGetRec(PF, RefNr, P, False); + if not IsamOK then begin + {Error handling} + Exit; + end; + FindRecord := True; + end; + + function MatchedRecord(P, Q : PersonDef) : Boolean; + begin + {Return True if P and Q match based on some criteria, for example...} + MatchedRecord := (StUpcase(P.City) = StUpcase(Q.City)); + end; + + function ScanForRecord(var P : PersonDef; KeyNr : Integer; + var RefNr : LongInt) : Boolean; + var + Done : Boolean; + Goal : PersonDef; + Key : IsamKeyStr; + begin + ScanForRecord := False; + Goal := P; + Done := False; + repeat + BTNextKey(PF, KeyNr, RefNr, Key); + if not IsamOK then + {Probably reached the largest key} + Done := True + else begin + BTGetRec(PF, RefNr, P, False); + if not IsamOK then begin + {Error handling} + Done := True; + end else if MatchedRecord(P, Goal) then begin + {Found a match} + Done := True; + ScanForRecord := True; + end; + end; + until Done; + end; + +begin + WriteLn('This program is just a collection of example routines'); + WriteLn('See SIMPDEMO.PAS or NETDEMO.PAS for working demo programs'); +end. diff --git a/src/wc_sdk/filer.inc b/src/wc_sdk/filer.inc new file mode 100644 index 0000000..96210ca --- /dev/null +++ b/src/wc_sdk/filer.inc @@ -0,0 +1,1815 @@ +{********************************************************************} +{* FILER.INC - high level B-Tree Filer routines *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{$IFDEF UseWindowsInit} +function BTInitIsam(ExpectedNet : NetSupportType; {!!.52} + Pages : integer) : integer; +var + Dummy : Boolean; +begin + BTInitIsam := 0; + if IsamIsInitialized then begin + IsamOK := False; + IsamError := 10450; + Exit; + end; + if (Pages < MaxHeight) then begin + IsamOK := False; + IsamError := 10451; + Exit; + end; + ISInitIsam; + {$IFDEF NoNet} + ExpectedNet := NoNet; + IsamNetEmu := False; + {$ELSE} + if not IsamInitNet(ExpectedNet) then begin + if IsamOK then begin + {-do not overwrite any error code} + IsamOK := False; + IsamError := 10310; + end; + Exit; + end; + IsamNetEmu := ExpectedNet = NoNet; + {$ENDIF} + IsamInitializedNet := ExpectedNet; + BTInitIsam := IsamGetPageBuffer(Pages); + if not IsamOK then begin + {$IFNDEF NoNet} + Dummy := IsamDoneNet; + {$ENDIF} + Exit; + end; + EMSHeapIsUsed := False; + IsamIsInitialized := True; +end; +{$ELSE} +function BTInitIsam(ExpectedNet : NetSupportType; + Free : LongInt; + NrOfEMSTreePages : Word) : LongInt; + {-Initializes B-Tree Isam; + high word of LResult: pages on EMS heap; + low word: pages on normal heap} +var + Dummy : Boolean; + LResult : LongInt; {!!.51} +begin + if IsamIsInitialized then begin + IsamOK := False; + IsamError := 10450; + Exit; + end; + ISInitIsam; + BTInitIsam := 0; + {$IFDEF NoNet} + ExpectedNet := NoNet; + IsamNetEmu := False; + {$ELSE} + if not IsamInitNet(ExpectedNet) then begin + if IsamOK then begin + {-do not overwrite any error code} + IsamOK := False; + IsamError := 10310; + end; + Exit; + end; + IsamNetEmu := ExpectedNet = NoNet; + {$ENDIF} + IsamInitializedNet := ExpectedNet; + {$IFDEF UseEMSHeap} + if not EMSHeapInitialized then begin + NrOfEMSTreePages := 0; + end; + {$ELSE} + NrOfEMSTreePages := 0; + {$ENDIF} + {$IFDEF UseEMSHeap} + if NrOfEMSTreePages > 0 then begin + if SizeOf (IsamPageEntry) > 16384 then begin + {$IFNDEF NoNet} + Dummy := IsamDoneNet; + {$ENDIF} + IsamOK := False; + IsamError := 10435; + Exit; + end; + UserSaveEMSHandle := SaveEMSCtxt; + end; + {$ENDIF} + if Free < 0 then + Free := 0; + LResult := IsamGetPageBuffer(Free, NrOfEMSTreePages); {!!.51} + BTInitIsam := LResult; {!!.51} + if not IsamOK then begin + {$IFDEF UseEMSHeap} + if NrOfEMSTreePages > 0 then begin + RestoreEMSCtxt(UserSaveEMSHandle); + UserSaveEMSHandle := 0; + end; + {$ENDIF} + {$IFNDEF NoNet} + Dummy := IsamDoneNet; + {$ENDIF} + Exit; + end; + {$IFDEF UseEMSHeap} + EMSHeapIsUsed := ILI (LResult).Hi <> 0; {!!.51} + {$IFDEF EMSDisturbance} + if EMSHeapIsUsed then + OwnSaveEMSHandle := SaveEMSCtxt; + {$ENDIF} + if NrOfEMSTreePages > 0 then begin + RestoreEMSCtxt(UserSaveEMSHandle); + UserSaveEMSHandle := 0; + end; + {$ELSE} + EMSHeapIsUsed := False; + {$ENDIF} + IsamIsInitialized := True; +end; +{$ENDIF} + + +procedure BTExitIsam; + {-Exits use of B-Tree Isam} +begin + IsamClearOK; + if not IsamIsInitialized then begin + IsamOK := False; + IsamError := 10455; + Exit; + end; + IsamCloseAllFileBlocks; + if not IsamOK then Exit; + {$IFDEF UseEMSHeap} + if EMSHeapIsUsed then begin + UserSaveEMSHandle := SaveEMSCtxt; + {$IFDEF EMSDisturbance} + RestoreEMSCtxt(OwnSaveEMSHandle); + {$ENDIF} + end; + {$ENDIF} + IsamIsInitialized := False; + IsamReleasePageBuffer; + {$IFNDEF NoNet} + if not IsamDoneNet then begin + IsamOK := False; + IsamError := 10315; + end; + {$ENDIF} + {$IFDEF UseEMSHeap} + if EMSHeapIsUsed then + RestoreEMSCtxt(UserSaveEMSHandle); + {$ENDIF} +end; + + +function BTIsamErrorClass : Integer; + {-Evaluates IsamError in error classes 0..4} +begin + case IsamError of + 0 : begin + BTIsamErrorClass := 0; + end; + 9903, + 10200..10299, + 10410 : begin + BTIsamErrorClass := 1; + end; + 9900, + 10065, + 10110, + 10306, + 10330, + 10332, + 10335, + 10355, + 10360, {!!.42} + 10390, {!!.42} + 10397, + 10399 : begin + BTIsamErrorClass := 2; + end; + 10001..10009 : begin + BTIsamErrorClass := 3; + end; + else + BTIsamErrorClass := 4; + end; {case} +end; + + +function BTNoNetCompiled : Boolean; + {-Returns True, if B-Tree Isam was compiled without network support} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + {$IFDEF NoNet} + BTNoNetCompiled := True; + {$ELSE} + BTNoNetCompiled := False; + {$ENDIF} + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +function BTPeekNoNetCompiled : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekNoNetCompiled := BTNoNetCompiled; + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +function BTNetSupported : NetSupportType; + {-Returns the currently supported network} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + BTNetSupported := IsamInitializedNet; + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +function BTPeekNetSupported : NetSupportType; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekNetSupported := BTNetSupported; + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +function BTFileBlockIsOpen(IFBPtr : IsamFileBlockPtr) : Boolean; + {-Returns True, if the fileblock is currently open} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + BTFileBlockIsOpen := IsamFileBlockIsInOpenList(IFBPtr); + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +function BTPeekFileBlockIsOpen(IFBPtr : IsamFileBlockPtr) : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekFileBlockIsOpen := BTFileBlockIsOpen(IFBPtr); + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +function BTIsNetFileBlock(IFBPtr : IsamFileBlockPtr) : Boolean; + {-Returns True, if the fileblock is a net fileblock} +begin + IsamEntryCode(IFBPtr, NoOptions); + {$IFDEF NoNet} + BTIsNetFileBlock := False; + {$ELSE} + BTIsNetFileBlock := IFBPtr^.NSP <> Nil; + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +function BTPeekIsNetFileBlock(IFBPtr : IsamFileBlockPtr) : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekIsNetFileBlock := BTIsNetFileBlock(IFBPtr); + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +function BTFileBlockIsLocked(IFBPtr : IsamFileBlockPtr) : Boolean; + {-Returns True, if the fileblock is currently locked} +begin + IsamEntryCode(IFBPtr, NoOptions); + BTFileBlockIsLocked := False; + {$IFNDEF NoNet} + if IFBPtr^.NSP <> Nil then + BTFileBlockIsLocked := IFBPtr^.NSP^.Locked; + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +function BTPeekFileBlockIsLocked(IFBPtr : IsamFileBlockPtr) : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekFileBlockIsLocked := BTFileBlockIsLocked(IFBPtr); + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +function BTFileBlockIsReadLocked(IFBPtr : IsamFileBlockPtr) : Boolean; + {-Returns True, if the fileblock is currently readlocked} +begin + IsamEntryCode(IFBPtr, NoOptions); + BTFileBlockIsReadLocked := False; + {$IFNDEF NoNet} + if IFBPtr^.NSP <> Nil then + BTFileBlockIsReadLocked := IFBPtr^.NSP^.ReadLocked; + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +function BTPeekFileBlockIsReadLocked(IFBPtr : IsamFileBlockPtr) : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekFileBlockIsReadLocked := BTFileBlockIsReadLocked(IFBPtr); + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +procedure BTReadLockFileBlock(IFBPtr : IsamFileBlockPtr); + {-Readlocks the fileblock IFBPtr^} +begin + IsamEntryCode(IFBPtr, NoOptions); + {$IFNDEF NoNet} + if IsamOK then + ISReadLockFileBlock(IFBPtr); + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +procedure BTLockFileBlock(IFBPtr : IsamFileBlockPtr); + {-Locks the fileblock IFBPtr^} +begin + IsamEntryCode(IFBPtr, NoOptions); + {$IFNDEF NoNet} + if IsamOK then + ISLockFileBlock(IFBPtr); + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +procedure BTUnLockFileBlock(IFBPtr : IsamFileBlockPtr); + {-Unlocks the fileblock IFBPtr^} +begin + IsamEntryCode(IFBPtr, NoOptions); + {$IFNDEF NoNet} + if IsamOK then + ISUnLockFileBlock(IFBPtr); + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +procedure BTUnLockAllOpenFileBlocks; + {-Unlocks all open fileblocks} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + {$IFNDEF NoNet} + if IsamOK then + ISUnLockAllOpenFileBlocks; + {$ENDIF} + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +procedure BTReadLockAllOpenFileBlocks; + {-Readlocks all open fileblocks} +var + TPtr : IsamOpenFileBlockListPtr; + Err : Integer; +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + {$IFNDEF NoNet} + if IsamOK then begin + TPtr := IsamOFBLPtr; + while (TPtr <> Nil) and IsamOK do begin + ISReadLockFileBlock(TPtr^.OIFBPtr); + if not IsamOK then begin + Err := IsamError; + ISUnLockAllOpenFileBlocks; + IsamOK := False; + IsamError := Err; + end; + TPtr := TPtr^.Next; + end; + end; + {$ENDIF} + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +procedure BTLockAllOpenFileBlocks; + {-Locks all open fileblocks} +var + TPtr : IsamOpenFileBlockListPtr; + Err : Integer; +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + {$IFNDEF NoNet} + if IsamOK then begin + TPtr := IsamOFBLPtr; + while (TPtr <> Nil) and IsamOK do begin + ISLockFileBlock(TPtr^.OIFBPtr); + if not IsamOK then begin + Err := IsamError; + ISUnLockAllOpenFileBlocks; + IsamOK := False; + IsamError := Err; + end; + TPtr := TPtr^.Next; + end; + end; + {$ENDIF} + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +procedure BTGetRecordInfo( IFBPtr : IsamFileBlockPtr; + Ref : LongInt; + var Start, Len : LongInt; + var Handle : IsamHandle); + {-Returns information about record Ref} +begin + IsamEntryCode(IFBPtr, NoOptions); + if IsamOK then begin + with IFBPtr^, DIDPtr^[0]^ do begin + Start := Ref * LenRec; + Len := LenRec; + Handle := DatF.Handle; + end; + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTPeekGetRecordInfo( IFBPtr : IsamFileBlockPtr; + Ref : LongInt; + var Start, Len : LongInt; + var Handle : IsamHandle); + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTGetRecordInfo(IFBPtr, Ref, Start, Len, Handle); + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +procedure BTLockRec(IFBPtr : IsamFileBlockPtr; Ref : LongInt); + {-Locks record Ref} +begin + IsamEntryCode(IFBPtr, NoOptions); + {$IFNDEF NoNet} + if IsamOK and (IFBPtr^.NSP <> Nil) then + ISLockRec(IFBPtr, Ref); + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +procedure BTUnLockRec(IFBPtr : IsamFileBlockPtr; Ref : LongInt); + {-Unlocks record Ref} +begin + IsamEntryCode(IFBPtr, NoOptions); + {$IFNDEF NoNet} + if IsamOK and (IFBPtr^.NSP <> Nil) then + ISUnLockRec(IFBPtr, Ref); + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +procedure BTUnLockAllRecs(IFBPtr : IsamFileBlockPtr); + {-Unlocks all locked records of IFBPtr^} +begin + IsamEntryCode(IFBPtr, NoOptions); + {$IFNDEF NoNet} + if IsamOK and (IFBPtr^.NSP <> Nil) then + IsamUnLockAllRecs(IFBPtr); + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +function BTRecIsLocked(IFBPtr : IsamFileBlockPtr; Ref : LongInt) + : Boolean; + {-Returns whether the record Ref is locked} +var + RefPtr : LongPtr; + Dummy1Ptr, + Dummy2Ptr : IsamLockEntryRecPtr; +begin + IsamEntryCode(IFBPtr, NoOptions); + BTRecIsLocked := False; + {$IFNDEF NoNet} + if IsamOK and (IFBPtr^.NSP <> Nil) then begin + IsamIsInLockList(@IFBPtr^.NSP^.LockEntryRec, Ref, RefPtr, + False, Dummy1Ptr, Dummy2Ptr); {!!.42} + BTRecIsLocked := RefPtr <> Nil; + end; + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +function BTPeekRecIsLocked(IFBPtr : IsamFileBlockPtr; Ref : LongInt) + : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekRecIsLocked := BTRecIsLocked(IFBPtr, Ref); + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +function BTaRecIsLocked(IFBPtr : IsamFileBlockPtr) : Boolean; + {-Returns whether a record is locked} + +begin + IsamEntryCode(IFBPtr, NoOptions); + BTaRecIsLocked := False; + {$IFNDEF NoNet} + if IsamOK and (IFBPtr^.NSP <> Nil) then begin + BTaRecIsLocked := IFBPtr^.NSP^.LockEntryRec.Count > 0; + end; + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +function BTPeekaRecIsLocked(IFBPtr : IsamFileBlockPtr) : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekaRecIsLocked := BTaRecIsLocked(IFBPtr); + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +procedure BTInformTTSAbortSuccessful(IFBPtr : IsamFileBlockPtr); + {-Resets all internal data to nothing buffered and no lock at all} +begin + IsamEntryCode(IFBPtr, NoOptions); + {$IFNDEF NoNet} + if IsamOK and (IFBPtr^.NSP <> Nil) then begin + with IFBPtr^.NSP^ do begin + if Locked then begin + if IsamUnLockAllFlagSets(IFBPtr) then; + Locked := False; + end; + if ReadLocked then begin + if IsamUnLockMyFlagSet(IFBPtr) then; + ReadLocked := False; + end; + while LockEntryRec.Count > 0 do begin + ISUnLockRec(IFBPtr, LockEntryRec.EntryArr [1]); + IsamClearOK; + end; + ReloadAll := True; + end; + end; + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +function BTSetDosRetry(NrOfRetries, WaitTime : Integer) : Boolean; + {-Sets number of retries and delay time between on locks and accesses + in a MicroSoft compatible network} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + {$IFDEF NoNet} + BTSetDosRetry := IsamOK; + {$ELSE} + BTSetDosRetry := IsamSetDosRetry(NrOfRetries, WaitTime); + {$ENDIF} + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +procedure BTForceWritingMark(FFM : Boolean); + {-Forces to write the "modify mark" to disk} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + IsamForceFlushOfMark := FFM; + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +procedure BTForceNetBufferWriteThrough(DoIt : Boolean); + {-with DoIt = True the save mode tries to suppress all buffering in a + network or multitasking environment} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + IsamNetEmu := DoIt; + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +procedure BTGetRec(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Dest; + ISOLock : Boolean); + {-Gets the specified record from the given reference} +var + Options : Word; +begin + if ISOLock then begin + Options := NoOptions; + end + else begin + Options := OptReadPrefix; + end; + IsamEntryCode(IFBPtr, Options); + if IsamOK then + IsamGetRec(IFBPtr, RefNr, Dest); + if IsamOK then begin {!!.50} + IFBPtr^.CharConvProc(@Dest, IFBPtr^.DIDPtr^[0]^.LenRec, {!!.50} + True, IFBPtr^.CCHookPtr); {!!.50} + end; {!!.50} + IsamExitCode(IFBPtr); +end; + + +procedure BTGetRecReadOnly(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Dest ); + {-Gets the specified record from the given reference even if it's locked} +begin + IsamEntryCode(IFBPtr, NoOptions); + if IsamOK then + IsamGetRecReadOnly(IFBPtr, RefNr, Dest); + if IsamOK or (IsamError = 10205) then begin {!!.50} + IFBPtr^.CharConvProc(@Dest, IFBPtr^.DIDPtr^[0]^.LenRec, {!!.50} + True, IFBPtr^.CCHookPtr); {!!.50} + end; {!!.50} + IsamExitCode(IFBPtr); +end; + + +procedure BTGetStartingLong(IFBPtr : IsamFileBlockPtr; {!!.42} + RefNr : LongInt; + var Dest : LongInt); + {-Gets the first four bytes of the specified record with the given + reference} +begin + IsamEntryCode(IFBPtr, NoOptions); + if IsamOK then + IsamGetStartingLong(IFBPtr, RefNr, Dest); + IsamExitCode(IFBPtr); +end; + + +procedure BTPutRec(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Source; + ISOLock : Boolean); + {-Puts the specified record at the given reference} +var + Options : Word; +begin + if ISOLock then begin + Options := OptWriteRoutine; {!!.41} + end + else begin + Options := OptCheckLock or OptWriteRoutine; {!!.41} + end; + IsamEntryCode(IFBPtr, Options); + if IsamOK then begin + IFBPtr^.CharConvProc(@Source, IFBPtr^.DIDPtr^[0]^.LenRec, {!!.50} + False, IFBPtr^.CCHookPtr); {!!.50} + IsamPutRec(IFBPtr, RefNr, Source); {!!.50} + if not IFBPtr^.CCDestrWrite then begin {!!.50} + IFBPtr^.CharConvProc(@Source, IFBPtr^.DIDPtr^[0]^.LenRec,{!!.50} + True, IFBPtr^.CCHookPtr); {!!.50} + end; {!!.50} + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTAddRec(IFBPtr : IsamFileBlockPtr; + var RefNr : LongInt; + var Source ); + {-Adds a record to the given fileblock and returns the reference} +begin + IsamEntryCode(IFBPtr, OptCheckLock or OptWriteRoutine); {!!.41} + if IsamOK then begin + IFBPtr^.CharConvProc(@Source, IFBPtr^.DIDPtr^[0]^.LenRec, {!!.50} + False, IFBPtr^.CCHookPtr); {!!.50} + IsamAddRec(IFBPtr, RefNr, Source); + if not IFBPtr^.CCDestrWrite then begin {!!.50} + IFBPtr^.CharConvProc(@Source, IFBPtr^.DIDPtr^[0]^.LenRec,{!!.50} + True, IFBPtr^.CCHookPtr); {!!.50} + end; {!!.50} + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTDeleteRec(IFBPtr : IsamFileBlockPtr; RefNr : LongInt); + {-Deletes the record with reference RefNr} +begin + IsamEntryCode(IFBPtr, OptCheckLock or OptWriteRoutine); {!!.41} + if IsamOK then + IsamDeleteRec(IFBPtr, RefNr); + IsamExitCode(IFBPtr); +end; + + +function BTUsedRecs(IFBPtr : IsamFileBlockPtr) : LongInt; + {-Returns the number of currently used records} +begin + IsamEntryCode(IFBPtr, OptReadPrefix); + if IsamOK then begin + with IFBPtr^.DIDPtr^[0]^ do begin + BTUsedRecs := NumRec - NumberFree; + end; + end + else begin + BTUsedRecs := 0; + end; + IsamExitCode(IFBPtr); +end; + + +function BTFreeRecs(IFBPtr : IsamFileBlockPtr) : LongInt; + {-Returns the number of currently not used records} +begin + IsamEntryCode(IFBPtr, OptReadPrefix); + if IsamOK then begin + BTFreeRecs := IFBPtr^.DIDPtr^[0]^.NumberFree; + end + else begin + BTFreeRecs := 0; + end; + IsamExitCode(IFBPtr); +end; + + +function BTFileLen(IFBPtr : IsamFileBlockPtr) : LongInt; + {-Returns the number of currently occupied records by this fileblock} +begin + IsamEntryCode(IFBPtr, OptReadPrefix); + if IsamOK then begin + BTFileLen := Succ (IFBPtr^.DIDPtr^[0]^.NumRec); + end + else begin + BTFileLen := 0; + end; + IsamExitCode(IFBPtr); +end; + + +function BTUsedKeys(IFBPtr : IsamFileBlockPtr; Key : Word) : LongInt; + {-Returns the number of currently used keys of the specified number} +begin + IsamEntryCode(IFBPtr, OptReadPrefix or OptKeyRoutine or Key); + if IsamOK then begin + BTUsedKeys := IFBPtr^.DIDPtr^[Key]^.NumKeys; + end + else begin + BTUsedKeys := 0; + end; + IsamExitCode(IFBPtr); +end; + + +function BTNrOfKeys(IFBPtr : IsamFileBlockPtr) : Word; + {-Returns the number of defined keys} +begin + IsamEntryCode(IFBPtr, NoOptions); + if IsamOK then begin + BTNrOfKeys := IFBPtr^.NrOfKeys; + end + else begin + BTNrOfKeys := 0; + end; + IsamExitCode(IFBPtr); +end; + + +function BTPeekNrOfKeys(IFBPtr : IsamFileBlockPtr) : Word; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekNrOfKeys := BTNrOfKeys(IFBPtr); + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +function BTDatRecordSize(IFBPtr : IsamFileBlockPtr) : LongInt; + {-Returns the lenght of a data record} +begin + IsamEntryCode(IFBPtr, NoOptions); + if IsamOK then begin + BTDatRecordSize := IFBPtr^.DIDPtr^[0]^.LenRec; + end + else begin + BTDatRecordSize := 0; + end; + IsamExitCode(IFBPtr); +end; + + +function BTPeekDatRecordSize(IFBPtr : IsamFileBlockPtr) : LongInt; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekDatRecordSize := BTDatRecordSize(IFBPtr); + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +function BTKeyRecordSize(IFBPtr : IsamFileBlockPtr) : LongInt; + {-Returns the maximum number of bytes used for a following key adding} +begin + IsamEntryCode(IFBPtr, NoOptions); + if IsamOK then begin + BTKeyRecordSize := IFBPtr^.BlockLen; + end + else begin + BTKeyRecordSize := 0; + end; + IsamExitCode(IFBPtr); +end; + + +function BTPeekKeyRecordSize(IFBPtr : IsamFileBlockPtr) : LongInt; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekKeyRecordSize := BTKeyRecordSize(IFBPtr); + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +function BTMinimumDatKeys(IFBPtr : IsamFileBlockPtr; Space : LongInt) + : LongInt; + {-Returns the minimum number of data (including keys), that can be placed + on a disk having Space bytes free Space} +var + Nr, + BL, + LR : LongInt; + PS : Word; +begin + IsamEntryCode(IFBPtr, NoOptions); + if IsamOK then begin + with IFBPtr^ do begin {!!.42} + BL := BlockLen; + LR := DIDPtr^[0]^.LenRec; {!!.42} + if NrOfKeys > 0 then begin {!!.42} + PS := DIDPtr^[1]^.UsedPageSize; {!!.42} + end + else begin {!!.42} + PS := CreatePageSize; {!!.42} + end; {!!.42} + end; + Nr := (Space - 2 * BL - LR) {!!.42} + Div (LR + BL Div LongInt (PS Shr 1)); + if Nr < 0 then begin + BTMinimumDatKeys := 0; + end + else begin + BTMinimumDatKeys := Nr; + end; + end + else begin + BTMinimumDatKeys := 0; + end; + IsamExitCode(IFBPtr); +end; + + +function BTPeekMinimumDatKeys(IFBPtr : IsamFileBlockPtr; + Space : LongInt) : LongInt; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekMinimumDatKeys := BTMinimumDatKeys(IFBPtr, Space); + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +procedure BTSetSearchForSequential(IFBPtr : IsamFileBlockPtr; + Key : Word; + ToOn : Boolean); {!!.TP} + {-Enables search mode in sequential key operations} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or Key); + if IsamOK then + IFBPtr^.DIDPtr^[Key]^.SearchForSequentialEnabled := ToOn; {!!.TP} + IsamExitCode(IFBPtr); +end; + + +procedure BTGetSearchForSequential(IFBPtr : IsamFileBlockPtr; + Key : Word; + var SFS : Boolean); + {-Tests search mode for sequential key operations} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or Key); + if IsamOK then + SFS := IFBPtr^.DIDPtr^[Key]^.SearchForSequentialEnabled; + IsamExitCode(IFBPtr); +end; + + +procedure BTFindRecRef(IFBPtr : IsamFileBlockPtr; + var UserDatRef : LongInt; + NotFoundSearchDirection : Integer); {!!.42} +begin + IsamEntryCode(IFBPtr, OptReadPrefix); + if IsamOK then begin + IsamFindRecRef(IFBPtr, UserDatRef, NotFoundSearchDirection); + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTNextRecRef(IFBPtr : IsamFileBlockPtr; + var UserDatRef : LongInt); {!!.42} +begin + IsamEntryCode(IFBPtr, OptReadPrefix); + if IsamOK then begin + Inc (UserDatRef); + IsamFindRecRef(IFBPtr, UserDatRef, 1); + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTPrevRecRef(IFBPtr : IsamFileBlockPtr; + var UserDatRef : LongInt); {!!.42} +begin + IsamEntryCode(IFBPtr, OptReadPrefix); + if IsamOK then begin + Dec (UserDatRef); + IsamFindRecRef(IFBPtr, UserDatRef, -1); + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTGetApprRecPos(IFBPtr : IsamFileBlockPtr; + var RelPos : Word; + Scale : Word; + UserDatRef : LongInt); {!!.42} +begin + IsamEntryCode(IFBPtr, OptReadPrefix); + if IsamOK then begin + IsamGetApprRecPos(IFBPtr, RelPos, Scale, UserDatRef); + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTGetApprRecRef(IFBPtr : IsamFileBlockPtr; + RelPos : Word; + Scale : Word; + var UserDatRef : LongInt); {!!.42} + +begin + IsamEntryCode(IFBPtr, OptReadPrefix); + if IsamOK then begin + IsamGetApprRecRef(IFBPtr, RelPos, Scale, UserDatRef); + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTClearKey(IFBPtr : IsamFileBlockPtr; Key : Word); + {-Places the internal sequential pointer to a null position} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptReadPrefix or Key); + if IsamOK then + IsamClearKey(IFBPtr, Key); + IsamExitCode(IFBPtr); +end; + + +procedure BTNextKey(IFBPtr : IsamFileBlockPtr; + Key : Word; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr ); + {-Returns in UserKey / UserDatRef the value and reference number of the + next key} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptReadPrefix or Key); + if IsamOK then begin {!!.41} + if IFBPtr^.DIDPtr^[Key]^.PathInd = 0 then begin {!!.41} + {-Key was cleared by a previous operation} {!!.41} + IsamClearKey(IFBPtr, Key); {!!.41} + {-Clear it again to allow sequential access} {!!.41} + end; {!!.41} + IsamNextKey(IFBPtr, Key, UserDatRef, UserKey); + end; {!!.41} + IsamExitCode(IFBPtr); +end; + + +procedure BTPrevKey(IFBPtr : IsamFileBlockPtr; + Key : Word; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr ); + {-Returns in UserKey / UserDatRef the value and reference number of the + previous key} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptReadPrefix or Key); + if IsamOK then begin {!!.41} + if IFBPtr^.DIDPtr^[Key]^.PathInd = 0 then begin {!!.41} + {-Key was cleared by a previous operation} {!!.41} + IsamClearKey(IFBPtr, Key); {!!.41} + {-Clear it again to allow sequential access} {!!.41} + end; {!!.41} + IsamPrevKey(IFBPtr, Key, UserDatRef, UserKey); + end; {!!.41} + IsamExitCode(IFBPtr); +end; + + +procedure BTFindKey(IFBPtr : IsamFileBlockPtr; + Key : Word; + var UserDatRef : LongInt; + UserKey : IsamKeyStr); + {-Returns in UserDatRef the reference number of the specified key} +var + TempKey : IsamKeyStr; +{$IFDEF ASCIIZeroKeys} + TempKeyZ : IsamKeyStr; +{$ENDIF} +{$IFDEF LengthByteKeys} + TempKeyZ : IsamKeyStr absolute UserKey; +{$ENDIF} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptReadPrefix or Key); + if IsamOK then begin + {$IFDEF ASCIIZeroKeys} + IsamMakeStrZ(UserKey, TempKeyZ); + {$ENDIF} + UserDatRef := 0; + IsamFindKey(IFBPtr, Key, UserDatRef, TempKeyZ); + if (not IsamOK) and (IsamError = 0) + and IFBPtr^.DIDPtr^[Key]^.AllowDupKeys then begin + IsamClearOK; + IsamNextKey(IFBPtr, Key, UserDatRef, TempKey); + IsamOK := IsamOK and (UserKey = TempKey); + end; + if not IsamOK then begin + case IsamError of + 0, 10200..10299 : IsamError := 10200; + end; {case} + end; + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTSearchKey(IFBPtr : IsamFileBlockPtr; + Key : Word; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr); + {-Returns in UserKey / UserDatRef the value and reference number of the + via UserKey specified or the following key} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptReadPrefix or Key); + if IsamOK then + IsamSearchKey(IFBPtr, Key, UserDatRef, UserKey); + IsamExitCode(IFBPtr); +end; + + +procedure BTFindKeyAndRef(IFBPtr : IsamFileBlockPtr; + Key : Word; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr; + NotFoundSearchDirection : Integer); + {-Returns in UserKey / UserDatRef the value and reference number of the + via UserKey / UserDatRef specified combination. + NotFoundSearchDirection determines whether and where to search for a + result in case nothing was found} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptReadPrefix or Key); + if IsamOK then + IsamFindKeyAndRef(IFBPtr, Key, UserDatRef, UserKey, NotFoundSearchDirection); + IsamExitCode(IFBPtr); +end; + + +procedure BTSearchKeyAndRef(IFBPtr : IsamFileBlockPtr; + Key : Word; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr); + {-Returns in UserKey / UserDatRef the value and reference number of the + via UserKey / UserDatRef specified combination. + in case nothing was found a following result is searched. if this does + not exist, a previous combination is searched} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptReadPrefix or Key); + if IsamOK then begin + IsamFindKeyAndRef(IFBPtr, Key, UserDatRef, UserKey, 1); + if IsamError = 10250 then begin + IsamClearOK; + IsamPrevKey(IFBPtr, Key, UserDatRef, UserKey); + end; + end; + IsamExitCode(IFBPtr); +end; + + +function BTKeyExists(IFBPtr : IsamFileBlockPtr; + Key : Word; + UserDatRef : LongInt; + UserKey : IsamKeyStr ) : Boolean; + {-Returns True, if the combination UserKey / UserDatRef exists} +var + C, K, L, R : Integer; + IPgPtr : IsamPagePtr; + ADK : Boolean; + {$IFDEF ASCIIZeroKeys} + TempKeyZ : IsamKeyStr; + {$ENDIF} + {$IFDEF LengthByteKeys} + TempKeyZ : IsamKeyStr absolute UserKey; + {$ENDIF} + {------} + procedure Search(PRef : LongInt); + begin + if PRef = 0 then begin + Exit; + end + else begin + IsamGetPage(IFBPtr, PRef, Key, IPgPtr); + if not IsamOK then Exit; + with IPgPtr^ do begin + L := 1; + R := ItemsOnPage; + ADK := IFBPtr^.DIDPtr^[Key]^.AllowDupKeys; + repeat + K :=(L + R) Shr 1; + C := IsamCompKeys(TempKeyZ, + ItemArray [K].KeyStr, + UserDatRef, + ItemArray [K].DataRef, + (UserDatRef <> 0) and ADK); + {-UserDatRef=0 means search independent of the data reference, + even if ADK is true} + if C <= 0 then + R := Pred (K); + if C >= 0 then + L := Succ (K); + until L > R; + if L - R > 1 then begin + BTKeyExists := True; + end + else begin + if R = 0 then begin + Search(BckwPageRef); + end + else begin + Search(ItemArray [R].PageRef); + end; + end; + end; + end; + end; + {------} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptReadPrefix or Key); + BTKeyExists := False; + if IsamOK then begin + {$IFDEF ASCIIZeroKeys} + IsamMakeStrZ(UserKey, TempKeyZ); + {$ENDIF} + Search(IFBPtr^.DIDPtr^[Key]^.RootRef); + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTNextDiffKey(IFBPtr : IsamFileBlockPtr; + Key : Word; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr ); + {-Returns in UserKey / UserDatRef the value and reference number of the + next from UserKey different key} +var + I : Integer; +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptReadPrefix or Key); + if IsamOK then begin + {$IFDEF LengthByteKeys} + if Length(UserKey) < IFBPtr^.DIDPtr^[Key]^.KeyLen then begin + UserKey := UserKey + #0; + end + else begin + I := IFBPtr^.DIDPtr^[Key]^.KeyLen; + repeat + UserKey [I] := Succ(UserKey [I]); + Dec (I); + until(I = 0) or(UserKey [Succ (I)] <> #0); + if UserKey [Succ (I)] = #0 then begin + IsamClearKey(IFBPtr, Key); + IsamOK := False; + IsamError := 10240; + end; + end; + {$ENDIF} + {$IFDEF ASCIIZeroKeys} + if Length(UserKey) < IFBPtr^.DIDPtr^[Key]^.KeyLen then begin + UserKey := UserKey + #1; + end + else begin + I := IFBPtr^.DIDPtr^[Key]^.KeyLen; + repeat + Inc(UserKey [I]); + if UserKey [I] = #0 then + Inc (UserKey [I]); + I := Pred (I); + until(I = 0) or(UserKey [Succ (I)] <> #1); + if UserKey [Succ (I)] = #1 then begin + IsamClearKey(IFBPtr, Key); + IsamOK := False; + IsamError := 10240; + Exit; + end; + end; + {$ENDIF} + end; + if IsamOK then begin + IsamSearchKey(IFBPtr, Key, UserDatRef, UserKey); + if not IsamOK then begin + case IsamError of + 0, 10200..10299 : IsamError := 10240; + end; {case} + end; + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTPrevDiffKey(IFBPtr : IsamFileBlockPtr; + Key : Word; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr ); + {-Returns in UserKey / UserDatRef the value and reference number of the + privious from UserKey different key} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptReadPrefix or Key); + if IsamOK then begin + IsamSearchKey(IFBPtr, Key, UserDatRef, UserKey); + case IsamError of + 0, 10200..10299 : + begin + IsamClearOK; + IsamPrevKey(IFBPtr, Key, UserDatRef, UserKey); + if IsamError = 10260 then + IsamError := 10245; + end; + end; {case} + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTAddKey(IFBPtr : IsamFileBlockPtr; + Key : Word; + UserDatRef : LongInt; + UserKey : IsamKeyStr ); + {-Adds the combination UserKey / UserDatRef to the tree} +var + {$IFDEF ASCIIZeroKeys} + TempKeyZ : IsamKeyStr; + {$ENDIF} + {$IFDEF LengthByteKeys} + TempKeyZ : IsamKeyStr absolute UserKey; + {$ENDIF} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptCheckLock or Key + or OptWriteRoutine); {!!.41} + if IsamOK then begin + if Length(UserKey) <= IFBPtr^.DIDPtr^[Key]^.KeyLen then begin + {$IFDEF ASCIIZeroKeys} + IsamMakeStrZ(UserKey, TempKeyZ); + {$ENDIF} + IsamAddKey(IFBPtr, Key, UserDatRef, TempKeyZ); + if IFBPtr^.SaveFB then begin + if IsamError = 0 then begin + IsamReduceDiaFile(IFBPtr); + end + else begin + IsamRepairFileBlock(IFBPtr); + if IsamOK then begin + IsamOK := False; + IsamError := 10003; + end; + end; + IsamResetSaveBuffered; + end; + if not IsamOK and (IsamError = 0) then + IsamError := 10230; + end + else begin + IsamOK := False; + IsamError := 10125; + end; + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTDeleteKey(IFBPtr : IsamFileBlockPtr; + Key : Word; + UserDatRef : LongInt; + UserKey : IsamKeyStr ); + {-Deletes the combination UserKey / UserDatRef in the tree} +var + {$IFDEF ASCIIZeroKeys} + TempKeyZ : IsamKeyStr; + {$ENDIF} + {$IFDEF LengthByteKeys} + TempKeyZ : IsamKeyStr absolute UserKey; + {$ENDIF} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptCheckLock or Key + or OptWriteRoutine); {!!.41} + if IsamOK then begin + {$IFDEF ASCIIZeroKeys} + IsamMakeStrZ(UserKey, TempKeyZ); + {$ENDIF} + IsamDeleteKey(IFBPtr, Key, UserDatRef, TempKeyZ); + if IFBPtr^.SaveFB then begin + if IsamError = 0 then begin + IsamReduceDiaFile(IFBPtr); + end + else begin + IsamRepairFileBlock(IFBPtr); + if IsamOK then begin + IsamOK := False; + IsamError := 10004; + end; + end; + IsamResetSaveBuffered; + end; + if not IsamOK and (IsamError = 0) then + IsamError := 10220; + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTDeleteAllKeys(IFBPtr : IsamFileBlockPtr; Key : Word); + {-Deletes all keys with number Key} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptCheckLock or Key + or OptWriteRoutine); {!!.41} + if IsamOK then begin + IsamDeleteAllKeys(IFBPtr, Key); + if IFBPtr^.SaveFB then begin + if IsamOK then begin + IsamReduceDiaFile(IFBPtr); + end + else begin + IsamRepairFileBlock(IFBPtr); + if IsamOK then begin + IsamOK := False; + IsamError := 10005; + end; + end; + end; + end; + IsamExitCode(IFBPtr); +end; + + +function BTOtherWSChangedKey(IFBPtr : IsamFileBlockPtr; + Key : Word) : Boolean; + {-Returns True, if it is definite, that a key of number Key was changed + by another workstation} +var + FlagSet : IsamFlagSet; + Dummy, + Valid : Boolean; +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or Key); + BTOtherWSChangedKey := False; + {$IFNDEF NoNet} + if IsamOK then begin + if IFBPtr^.NSP <> Nil then begin + with IFBPtr^.NSP^ do begin + if not (Locked or ReadLocked) then begin + IsamLockAndGetFlagSet(IFBPtr, FlagSet, Valid); + if IsamOK and Valid then begin + BTOtherWSChangedKey := Key in FlagSet; + Dummy := IsamUnLockMyFlagSet(IFBPtr); + end; + end; + end; + end; + end; + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +procedure BTGetApprRelPos(IFBPtr : IsamFileBlockPtr; + Key : Word; + var RelPos : Word; + Scale : Word; + UserKey : IsamKeyStr; + UserDatRef : LongInt); + {-Returns in RelPos the approximate relative position of the combination + UserKey / UserDatRef in 0..Scale} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptReadPrefix or Key); + if IsamOK then + IsamGetApprRelPos(IFBPtr, Key, RelPos, Scale, UserKey, UserDatRef); + IsamExitCode(IFBPtr); +end; + + +procedure BTGetApprKeyAndRef(IFBPtr : IsamFileBlockPtr; + Key, + RelPos : Word; + Scale : Word; + var UserKey : IsamKeyStr; + var UserDatRef : LongInt); + {-Returns the combination UserKey / UserDatRef, that is approximately + at the position RelPos in 0..Scale} +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or OptReadPrefix or Key); + if IsamOK then begin + IsamGetApprKeyAndRef(IFBPtr, Key, RelPos, Scale, UserKey, UserDatRef); + end; + IsamExitCode(IFBPtr); +end; + + +procedure BTFlushAllFileBlocks; + {-Flushes all new data of all fileblocks to disk} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + if IsamOK then + IsamFlushAllFileBlocks; + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +procedure BTFlushFileBlock(IFBPtr : IsamFileBlockPtr); + {-Flushes all new data of this fileblocks to disk} +begin + IsamEntryCode(IFBPtr, NoOptions); + if IsamOK then + IsamFlushFileBlock(IFBPtr); + IsamExitCode(IFBPtr); +end; + + +procedure BTDeleteFileBlock(FName : IsamFileBlockName); + {-Deletes a fileblock} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + if IsamOK then + IsamDeleteFileBlock(FName); + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +procedure BTCreateFileBlock(FName : IsamFileBlockName; + DatSLen : LongInt; + NumberOfKeys : Word; + IID : IsamIndDescr); + {-Creates a closed fileblock} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + if IsamOK then + IsamCreateFileBlock(FName, DatSLen, NumberOfKeys, IID); + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +procedure BTOpenFileBlock(var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName; + ReadOnly, + AllReadOnly, + Save, + Net : Boolean); + {-Opens a fileblock} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + if IsamOK then + IsamOpenFileBlock(IFBPtr, FName, ReadOnly, AllReadOnly, Save, Net); + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +procedure BTCloseFileBlock(var IFBPtr : IsamFileBlockPtr); + {-Closes a fileblock} +begin + IsamEntryCode(IFBPtr, NoOptions); + if IsamOK then + IsamCloseFileBlock(IFBPtr); + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +procedure BTCloseAllFileBlocks; + {-Closes all open fileblocks} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + if IsamOK then + IsamCloseAllFileBlocks; + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +function BTDataFileName(IFBPtr : IsamFileBlockPtr) : IsamFileName; + {-Returns the name of the data file including path and extension} +begin + IsamEntryCode(IFBPtr, NoOptions); + if IsamOK then begin + BTDataFileName := IsamGetFileName(IFBPtr^.DatF); + end + else begin + BTDataFileName := ''; + end; + IsamExitCode(IFBPtr); +end; + + +function BTPeekDataFileName(IFBPtr : IsamFileBlockPtr) : IsamFileName; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekDataFileName := BTDataFileName(IFBPtr); + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +function BTIndexFileName(IFBPtr : IsamFileBlockPtr) : IsamFileName; + {-Returns the name of the index file including path and extension} +begin + IsamEntryCode(IFBPtr, NoOptions); + BTIndexFileName := ''; + if IsamOK then begin + if IFBPtr^.NrOfKeys > 0 then begin + BTIndexFileName := IsamGetFileName(IFBPtr^.IndF); + end; + end; + IsamExitCode(IFBPtr); +end; + + +function BTPeekIndexFileName(IFBPtr : IsamFileBlockPtr) : IsamFileName; + {-Just like the routine without "Peek", but not destroying the previous + error on success} +var + ErrSt : ErrStatSaveRec; +begin + SaveErrorStat(ErrSt); + BTPeekIndexFileName := BTIndexFileName(IFBPtr); + if IsamOK then + RestoreErrorStat(ErrSt); +end; + + +function BTGetNextUsedAddRecRef(IFBPtr : IsamFileBlockPtr) : LongInt; + {-Returns the data reference, that is used for adding the next record; + this function is of a more internal nature} +begin + IsamEntryCode(IFBPtr, NoOptions); + BTGetNextUsedAddRecRef := 0; + if IsamOK then begin + BTGetNextUsedAddRecRef := IsamGetNextUsedAddRecRef(IFBPtr); + end; + IsamExitCode(IFBPtr); +end; + + +function BTGetAfterNextUsedAddRecRef(IFBPtr : IsamFileBlockPtr) : LongInt; + {-Returns the data reference, that is used after adding the next record; + this function is of a more internal nature} +begin + IsamEntryCode(IFBPtr, NoOptions); + BTGetAfterNextUsedAddRecRef := 0; + if IsamOK then begin + BTGetAfterNextUsedAddRecRef := IsamGetAfterNextUsedAddRecRef(IFBPtr); + end; + IsamExitCode(IFBPtr); +end; + + +function BTGetInternalDialogID(IFBPtr : IsamFileBlockPtr) : Word; + {-Returns the internal ID used by network accesss to this fileblock} +begin + IsamEntryCode(IFBPtr, NoOptions); + BTGetInternalDialogID := 0; + {$IFNDEF NoNet} + if IsamOK then begin {!!.42} + if IFBPtr^.NSP <> Nil then begin + BTGetInternalDialogID := IFBPtr^.NSP^.LocalWSNr; + end; + end; {!!.42} + {$ENDIF} + IsamExitCode(IFBPtr); +end; + + +function BTGetAllowDupKeys(IFBPtr : IsamFileBlockPtr; {!!.50} + KeyNr : Word) : Boolean; +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or KeyNr); + BTGetAllowDupKeys := False; + if IsamOK then begin + BTGetAllowDupKeys := IFBPtr^.DIDPtr^[KeyNr]^.AllowDupKeys; + end; + IsamExitCode(IFBPtr); +end; + + +function BTGetKeyLen(IFBPtr : IsamFileBlockPtr; {!!.50} + KeyNr : Word) : Word; +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or KeyNr); + BTGetKeyLen := 0; + if IsamOK then + BTGetKeyLen := IFBPtr^.DIDPtr^[KeyNr]^.KeyLen; + IsamExitCode(IFBPtr); +end; + + +procedure BTNoCharConvert(DataPtr : Pointer; {!!.50} + DataLen : LongInt; + PostRead : Boolean; + HookPtr : Pointer); +begin +end; + + +procedure BTSetCharConvert(IFBPtr : IsamFileBlockPtr; {!!.50} + CCProc : ProcBTCharConvert; + HookPtr : Pointer; + DestrWrite : Boolean); +begin + IsamEntryCode(IFBPtr, NoOptions); + if IsamOK then begin + with IFBPtr^ do begin + CharConvProc := CCProc; + CCHookPtr := HookPtr; + CCDestrWrite := DestrWrite; + end; + end; + IsamExitCode(IFBPtr); +end; + + +function BTIsInitialized : Boolean; {!!.50} +begin + BTIsInitialized := IsamIsInitialized; +end; + + +(*****************************************************************************) +{--Compatibility calls} +function BTIsamLockRecord(Start, + Len : LongInt; + Handle : IsamHandle; + TimeOut, + DelayTime : Word) : Boolean; + {-Locks bytes Start to Start - Len + 1 in the file + with handle Handle} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + BTIsamLockRecord := True; + {$IFNDEF NoNet} + if IsamOK then begin + BTIsamLockRecord := btfLockMgrAcqLock(Handle, Start, Len, TimeOut, DelayTime); + end; + {$ENDIF} + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +function BTIsamUnLockRecord(Start, + Len : LongInt; + Handle : IsamHandle) : Boolean; + {-Unlocks bytes Start to Start - Len + 1 in the file + with handle Handle} +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); + BTIsamUnLockRecord := True; + {$IFNDEF NoNet} + if IsamOK then + BTIsamUnLockRecord := btfLockMgrRelLock(Handle, Start, Len); + {$ENDIF} + IsamExitCode(Pointer (NotAFileBlockPtr)); +end; + + +function BTIsamGetSequentialOK(IFBPtr : IsamFileBlockPtr; {!!.50} + KeyNr : Word) : Boolean; +begin + IsamEntryCode(IFBPtr, OptKeyRoutine or KeyNr); + BTIsamGetSequentialOK := False; + if IsamOK then begin + BTIsamGetSequentialOK := IFBPtr^.DIDPtr^[KeyNr]^.SequentialOK; + end; + IsamExitCode(IFBPtr); +end; + + +function IsamGetNumRecAddress(IFBPtr : IsamFileBlockPtr) : Pointer; + {!!.50} +begin + IsamEntryCode(IFBPtr, NoOptions); + IsamGetNumRecAddress := Nil; + if IsamOK then begin + IsamGetNumRecAddress := @IFBPtr^.DIDPtr^[0]^.NumRec; + end; + IsamExitCode(IFBPtr); +end; + diff --git a/src/wc_sdk/filer.pas b/src/wc_sdk/filer.pas new file mode 100644 index 0000000..cf0a055 --- /dev/null +++ b/src/wc_sdk/filer.pas @@ -0,0 +1,959 @@ +{********************************************************************} +{* FILER.PAS - B-Tree Filer main unit *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * Rob Roberts robr@pcisys.net + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} + +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + +{$IFDEF Win32} +{$H-} {no long string support} +{$ENDIF} + +Unit + Filer; + +interface + +Uses + BTBase, + BTFileIO, + BTIsBase, +{$IFDEF Win32} + Windows, SysUtils; {!!.52} +{$ELSE} {!!.52} +{$IFDEF UseEMSHeap} + EMSHeap, +{$ENDIF} +{$IFDEF UsingDelphi} + SysUtils, +{$ENDIF} +{$IFDEF SupportVLM} + nwBase, nwBind, nwConn, nwFile, +{$ENDIF} + BaseSupp; +{$ENDIF} {!!.52} + + +(***************************************************************************) + {-Beyond this point there are no user changeable settings} + +{--Interfaced constants} +Const + VersionStr = '05.57a'; {!!.57a} + {-Current version} + + MinimizeUseOfNormalHeap = $40000000; + {-This value added to Free for BTInitIsam causes the ring buffer to + use a minimum of normal heap} + + MaxLockEntries = 4; + {-Maxiximum number of entries for record locks per level. Multiple levels + guaranty as much as the heap allows} + +{--Interfaced types} +Type + IsamFileBlockName = String [192]; + {-DOS name of a fileblock} + + IsamKeyStr = String [MaxKeyLen]; + {-A key string} + + IsamFileBlockPtr = ^IsamFileBlock; + {-Pointer to a fileblock} + + IsamIndDescr = Array [1..MaxNrOfKeys] Of packed Record + KeyL : 1..MaxKeyLen; + AllowDupK : Boolean; + End; + {-Descriptor of the index file} + + ProcBTCharConvert = Procedure ( DataPtr : Pointer; {!!.50} + DataLen : LongInt; + PostRead : Boolean; + HookPtr : Pointer ); + + TIsamReXUserProc = procedure (KeyNr : integer; + NumRecsRead : longint; + NumRecsWritten : longint; + var Data; + Len : word); + {-ReStruct/ReIndex user progress procedural type} + +{--Privat types} + IsamItem = packed Record + DataRef, + PageRef : LongInt; + KeyStr : IsamKeyStr; + End; + IsamPage = packed Record + ItemsOnPage : Word; {0..MaxPageSize, but must occupy 2 Byte} + BckwPageRef : LongInt; + ItemArray : Array [1..MaxPageSize] Of IsamItem; {!!.42} + End; + IsamPagePtr = ^IsamPage; + IsamSearchStep = packed Record + PageRef : LongInt; + ItemArrInd : 0..MaxPageSize; {!!.42} + End; + IsamPath = Array [1..MaxHeight] Of IsamSearchStep; + IsamDatIndDescr = packed Record + NumKeys, + FirstFree, + NumberFree, + NumRec, + LenRec, + RootRef : LongInt; + UsedPageSize : Word; {!!.42} + AllowDupKeys, + InfoRecChanged, + IRChangedSaveN, + FirstFreeChanged, + SearchForSequentialEnabled, + SequentialOK : Boolean; + KeyLen : 1..MaxKeyLen; + BlockOfs : LongInt; + Path : IsamPath; + PathInd : 0..MaxHeight; + End; + IsamDatIndDescrPtr = ^IsamDatIndDescr; + IsamDatIndDescrAr = Array [0..MaxNrOfKeys] Of IsamDatIndDescrPtr; + IsamLockEntryRecPtr = ^IsamLockEntryRec; + IsamLockEntryRec = packed Record + EntryArr : Array [1..MaxLockEntries] Of LongInt; + Count : 0..MaxLockEntries; + Next : IsamLockEntryRecPtr; + End; + IsamNetSupport = packed Record + Locked, + ReadLocked, + FlagSetReadLocked, + AllStationsReadOnly, + ReloadAll, + SaveFileBlockRepaired : Boolean; + DiaLenM3 : LongInt; + SetLen : Word; + LocalWSNr : Word; + SupNrOfWS : Word; {!!.42} + LockEntryRec : IsamLockEntryRec; + End; + IsamNetSupportPtr = ^IsamNetSupport; + IsamFileBlock = packed Record + ValidSign : LongInt; + DatF : IsamFile; + IndF : IsamFile; + DiaF : IsamFile; + NrOfKeys : 0..MaxNrOfKeys; + BlockLen, + MaxPages : LongInt; + DIDPtr : ^IsamDatIndDescrAr; + DataBuffered, + ReadOnlyFB, + SaveFB : Boolean; + NSP : IsamNetSupportPtr; + CharConvProc : ProcBTCharConvert; {!!.50} + CCHookPtr : Pointer; {!!.50} + CCDestrWrite : Boolean; {!!.50} + End; + IsamOpenFileBlockListPtr = ^IsamOpenFileBlockList; + IsamOpenFileBlockList = packed Record + Next : IsamOpenFileBlockListPtr; + OIFBPtr : IsamFileBlockPtr; + End; + IsamSmallInfoRec = packed Record + Gener : Array [1..5] Of LongInt; + ADK : Boolean; + End; + IsamInfoRec = packed Record + InfoRec : IsamSmallInfoRec; + DummyFill : Char; + KeysUsed : LongInt;{Must start on an even offset for C-compatibility} + PageSizeUsed : Word; {!!.42} + End; + IsamSaveInfoRecBuffer = packed Record + IST, + IndNr : Word; + BIR : IsamInfoRec; + SFF : LongInt; + End; + IsamRingBufferRecPtr = ^IsamRingBufferRec; + IsamPageEntryPtr = ^IsamPageEntry; + IsamRingBufferRec = packed Record + Prev, + Next : IsamRingBufferRecPtr; + IFBlPtr : IsamFileBlockPtr; + PageRef : LongInt; + PageEntryPtr : IsamPageEntryPtr; + KeyNr : Word; + UpDated, + EMSEntry, + SaveBuffered : Boolean; + End; + IsamPageEntry = packed Record + Page : IsamPage; + DummyDist1, + DummyDist2 : LongInt; + RingBufferPtr : IsamRingBufferRecPtr; + End; + ILI = packed Record + Lo, Hi : Word; + End; + IsamFlagSet = Set Of Byte; + +Const + IsamSmallInfoRecSize = SizeOf (IsamSmallInfoRec); + IsamPageEntrySize = SizeOf (IsamPageEntry); + {-Compatibility constants to DLL version} + +{--Interfaced variables} +Var + IsamReXUserProcPtr : TIsamReXUserProc; + {-Pointer to a routine used while rebuilding and reorganizing} + + IsamCompiledNets : Set Of NetSupportType; + {-Initialized of the unit initialization code; + contains the definined network interfaces} + +{--Interfaced routines} + {$IFDEF UseWindowsInit} + Function BTInitIsam ( ExpectedNet : NetSupportType; {!!.52} + Pages : integer ) : integer; + {-Initializes B-Tree Isam; + Result -- pages on normal heap} + {$ELSE} + Function BTInitIsam ( ExpectedNet : NetSupportType; + Free : LongInt; + NrOfEMSTreePages : Word ) : LongInt; + {-Initializes B-Tree Isam; + high word of result: pages on EMS heap; low word: pages on normal heap} + {$ENDIF} + + Procedure BTExitIsam; + {-Exits use of B-Tree Isam} + + Function BTIsamErrorClass : Integer; + {-Evaluates IsamError in error classes 0..4} + + Procedure BTReadLockFileBlock ( IFBPtr : IsamFileBlockPtr ); + {-Readlocks the fileblock IFBPtr^} + + Procedure BTLockFileBlock ( IFBPtr : IsamFileBlockPtr ); + {-Locks the fileblock IFBPtr^} + + Procedure BTUnLockFileBlock ( IFBPtr : IsamFileBlockPtr ); + {-Unlocks the fileblock IFBPtr^} + + Procedure BTReadLockAllOpenFileBlocks; + {-Readlocks all open fileblocks} + + Procedure BTLockAllOpenFileBlocks; + {-Locks all open fileblocks} + + Procedure BTUnLockAllOpenFileBlocks; + {-Unlocks all open fileblocks} + + Procedure BTLockRec ( IFBPtr : IsamFileBlockPtr; Ref : LongInt ); + {-Locks record Ref} + + Procedure BTUnLockRec ( IFBPtr : IsamFileBlockPtr; Ref : LongInt ); + {-Unlocks record Ref} + + Procedure BTUnLockAllRecs ( IFBPtr : IsamFileBlockPtr ); + {-Unlocks all locked records of IFBPtr^} + + Function BTRecIsLocked ( IFBPtr : IsamFileBlockPtr; Ref : LongInt ) + : Boolean; + {-Returns whether the record Ref is locked} + + Function BTPeekRecIsLocked ( IFBPtr : IsamFileBlockPtr; Ref : LongInt ) + : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Function BTaRecIsLocked ( IFBPtr : IsamFileBlockPtr ) : Boolean; + {-Returns whether a record is locked} + + Function BTPeekaRecIsLocked ( IFBPtr : IsamFileBlockPtr ) : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Procedure BTInformTTSAbortSuccessful ( IFBPtr : IsamFileBlockPtr ); + {-Resets all internal data to nothing buffered and no lock at all} + + Procedure BTGetRecordInfo ( IFBPtr : IsamFileBlockPtr; + Ref : LongInt; + Var Start, Len : LongInt; + Var Handle : IsamHandle); + {-Returns information about record Ref} + + Procedure BTPeekGetRecordInfo ( IFBPtr : IsamFileBlockPtr; + Ref : LongInt; + Var Start, Len : LongInt; + Var Handle : IsamHandle); + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Function BTFileBlockIsOpen ( IFBPtr : IsamFileBlockPtr ) : Boolean; + {-Returns True, if the fileblock is curently open} + + Function BTPeekFileBlockIsOpen ( IFBPtr : IsamFileBlockPtr ) : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Function BTFileBlockIsLocked ( IFBPtr : IsamFileBlockPtr ) : Boolean; + {-Returns True, if the fileblock is currently locked} + + Function BTPeekFileBlockIsLocked ( IFBPtr : IsamFileBlockPtr ) : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Function BTFileBlockIsReadLocked ( IFBPtr : IsamFileBlockPtr ) : Boolean; + {-Returns True, if the fileblock is currently readlocked} + + Function BTPeekFileBlockIsReadLocked ( IFBPtr : IsamFileBlockPtr ) + : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Procedure BTForceWritingMark ( FFM : Boolean ); + {-Forces to write the "modify mark" to disk} + + Function BTSetDosRetry ( NrOfRetries, WaitTime : Integer ) : Boolean; + {-Sets number of retries and delay time between on locks and accesses + in a MicroSoft compatible network} + + Function BTNetSupported : NetSupportType; + {-Returns the currently supported network} + + Function BTPeekNetSupported : NetSupportType; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Function BTNoNetCompiled : Boolean; + {-Returns True, if B-Tree Isam was compiled without network support} + + Function BTPeekNoNetCompiled : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Function BTIsNetFileBlock ( IFBPtr : IsamFileBlockPtr ) : Boolean; + {-Returns True, if the fileblock is a net fileblock} + + Function BTPeekIsNetFileBlock ( IFBPtr : IsamFileBlockPtr ) : Boolean; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Procedure BTForceNetBufferWriteThrough ( DoIt : Boolean ); + {-With DoIt = True the save mode tries to suppress all buffering in a + network or multitasking environment} + + Procedure BTPutRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Source; + ISOLock : Boolean ); + {-Puts the specified record at the given reference} + + Procedure BTGetRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest; + ISOLock : Boolean ); + {-Gets the specified record from the given reference} + + Procedure BTGetRecReadOnly ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest ); + {-Gets the specified record from the given reference even if it's locked} + + Procedure BTGetStartingLong ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest : LongInt ); + {-Gets the first four bytes of the specified record with the given + reference} + + Procedure BTAddRec ( IFBPtr : IsamFileBlockPtr; + Var RefNr : LongInt; + Var Source ); + {-Adds a record to the given fileblock and returns the reference} + + Procedure BTDeleteRec ( IFBPtr : IsamFileBlockPtr; RefNr : LongInt ); + {-Deletes the record with reference RefNr} + + Function BTUsedRecs ( IFBPtr : IsamFileBlockPtr ) : LongInt; + {-Returns the number of currently used records} + + Function BTUsedKeys ( IFBPtr : IsamFileBlockPtr; Key : Word ) : LongInt; + {-Returns the number of currently used keys of the specified number} + + Function BTFreeRecs ( IFBPtr : IsamFileBlockPtr ) : LongInt; + {-Returns the number of currently not used records} + + Function BTFileLen ( IFBPtr : IsamFileBlockPtr ) : LongInt; + {-Returns the number of currently occupied records by this fileblock} + + Function BTNrOfKeys ( IFBPtr : IsamFileBlockPtr ) : Word; + {-Returns the number of defined keys} + + Function BTPeekNrOfKeys ( IFBPtr : IsamFileBlockPtr ) : Word; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Function BTDatRecordSize ( IFBPtr : IsamFileBlockPtr ) : LongInt; + {-Returns the lenght of a data record} + + Function BTPeekDatRecordSize ( IFBPtr : IsamFileBlockPtr ) : LongInt; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Function BTKeyRecordSize ( IFBPtr : IsamFileBlockPtr ) : LongInt; + {-Returns the maximum number of bytes used for a following key adding} + + Function BTPeekKeyRecordSize ( IFBPtr : IsamFileBlockPtr ) : LongInt; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Function BTMinimumDatKeys ( IFBPtr : IsamFileBlockPtr; Space : LongInt ) + : LongInt; + {-Returns the minimum number of data (including keys), that can be placed + on a disk having Space bytes free space} + + Function BTPeekMinimumDatKeys ( IFBPtr : IsamFileBlockPtr; + Space : LongInt ) : LongInt; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Procedure BTSetSearchForSequential ( IFBPtr : IsamFileBlockPtr; + Key : Word; + ToOn : Boolean ); + {-Sets search mode in sequential key operations to ToOn} + + Procedure BTGetSearchForSequential ( IFBPtr : IsamFileBlockPtr; + Key : Word; + Var SFS : Boolean ); + {-Gets search mode for sequential key operations in TSFS} + + Procedure BTFindRecRef ( IFBPtr : IsamFileBlockPtr; + Var UserDatRef : LongInt; + NotFoundSearchDirection : Integer ); {!!.42} + {-Returns in UserDatRef the reference number of the found record; + NotFoundSearchDirection determines whether and how to search + in case nothing was found} + + Procedure BTNextRecRef ( IFBPtr : IsamFileBlockPtr; + Var UserDatRef : LongInt ); {!!.42} + {-Returns in UserDatRef the reference number of the next record} + + Procedure BTPrevRecRef ( IFBPtr : IsamFileBlockPtr; + Var UserDatRef : LongInt ); {!!.42} + {-Returns in UserDatRef the reference number of the previous record} + + Procedure BTGetApprRecPos ( IFBPtr : IsamFileBlockPtr; + Var RelPos : Word; + Scale : Word; + UserDatRef : LongInt ); {!!.42} + {-Returns in RelPos the approximate relative position of the record + with reference UserDatRef in 0..Scale} + + Procedure BTGetApprRecRef ( IFBPtr : IsamFileBlockPtr; + RelPos : Word; + Scale : Word; + Var UserDatRef : LongInt ); {!!.42} + {-Returns UserDatRef, that is approximately at the position RelPos + in 0..Scale} + + Procedure BTClearKey ( IFBPtr : IsamFileBlockPtr; Key : Word ); + {-Places the internal sequential pointer to a null position} + + Procedure BTNextKey ( IFBPtr : IsamFileBlockPtr; + Key : Word; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + {-Returns in UserKey / UserDatRef the value and reference number of the + next key} + + Procedure BTPrevKey ( IFBPtr : IsamFileBlockPtr; + Key : Word; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + {-Returns in UserKey / UserDatRef the value and reference number of the + privious key} + + Procedure BTFindKey ( IFBPtr : IsamFileBlockPtr; + Key : Word; + Var UserDatRef : LongInt; + UserKey : IsamKeyStr ); + {-Returns in UserDatRef the reference number of the specified key} + + Procedure BTSearchKey ( IFBPtr : IsamFileBlockPtr; + Key : Word; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + {-Returns in UserKey / UserDatRef the value and reference number of the + via UserKey specified or the following key} + + Procedure BTFindKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Word; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr; + NotFoundSearchDirection : Integer ); + {-Returns in UserKey / UserDatRef the value and reference number of the + via UserKey / UserDatRef specified combination. + NotFoundSearchDirection determines whether and where to search for a + result in case nothing was found} + + Procedure BTSearchKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Word; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + {-Returns in UserKey / UserDatRef the value and reference number of the + via UserKey / UserDatRef specified combination. + In case nothing was found a following result is searched. If this does + not exist, a previous combination is searched} + + Function BTKeyExists ( IFBPtr : IsamFileBlockPtr; + Key : Word; + UserDatRef : LongInt; + UserKey : IsamKeyStr ) : Boolean; + {-Returns True, if the combination UserKey / UserDatRef exists} + + Procedure BTNextDiffKey ( IFBPtr : IsamFileBlockPtr; + Key : Word; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + {-Returns in UserKey / UserDatRef the value and reference number of the + next from UserKey different key} + + Procedure BTPrevDiffKey ( IFBPtr : IsamFileBlockPtr; + Key : Word; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + {-Returns in UserKey / UserDatRef the value and reference number of the + previous from UserKey different key} + + Procedure BTAddKey ( IFBPtr : IsamFileBlockPtr; + Key : Word; + UserDatRef : LongInt; + UserKey : IsamKeyStr ); + {-Adds the combination UserKey / UserDatRef to the tree} + + Procedure BTDeleteKey ( IFBPtr : IsamFileBlockPtr; + Key : Word; + UserDatRef : LongInt; + UserKey : IsamKeyStr ); + {-Deletes the combination UserKey / UserDatRef in the tree} + + Procedure BTDeleteAllKeys ( IFBPtr : IsamFileBlockPtr; Key : Word ); + {-Deletes all keys with number Key} + + Function BTOtherWSChangedKey ( IFBPtr : IsamFileBlockPtr; + Key : Word ) : Boolean; + {-Returns True, if it is definite, that a key of number Key was changed + by another work station} + + Procedure BTGetApprRelPos ( IFBPtr : IsamFileBlockPtr; + Key : Word; + Var RelPos : Word; + Scale : Word; + UserKey : IsamKeyStr; + UserDatRef : LongInt ); + {-Returns in RelPos the approximate relative position of the combination + UserKey / UserDatRef in 0..Scale} + + Procedure BTGetApprKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key, + RelPos : Word; + Scale : Word; + Var UserKey : IsamKeyStr; + Var UserDatRef : LongInt ); + {-Returns the combination UserKey / UserDatRef, that is approximately + at the position RelPos in 0..Scale} + + Procedure BTFlushAllFileBlocks; + {-Flushes all new data of all fileblocks to disk} + + Procedure BTFlushFileBlock ( IFBPtr : IsamFileBlockPtr ); + {-Flushes all new data of this fileblocks to disk} + + Procedure BTCreateFileBlock ( FName : IsamFileBlockName; + DatSLen : LongInt; + NumberOfKeys : Word; + IID : IsamIndDescr ); + {-Creates a closed fileblock} + + Procedure BTOpenFileBlock ( Var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName; + ReadOnly, + AllReadOnly, + Save, + Net : Boolean ); + {-Opens a fileblock} + + Procedure BTCloseFileBlock ( Var IFBPtr : IsamFileBlockPtr ); + {-Closes a fileblock} + + Procedure BTCloseAllFileBlocks; + {-Closes all open fileblocks} + + Procedure BTDeleteFileBlock ( FName : IsamFileBlockName ); + {-Deletes a fileblock} + + Function BTDataFileName ( IFBPtr : IsamFileBlockPtr ) : IsamFileName; + {-Returns the name of the data file including path and extension} + + Function BTPeekDataFileName ( IFBPtr : IsamFileBlockPtr ) : IsamFileName; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Function BTIndexFileName ( IFBPtr : IsamFileBlockPtr ) : IsamFileName; + {-Returns the name of the index file including path and extension} + + Function BTPeekIndexFileName ( IFBPtr : IsamFileBlockPtr ) : IsamFileName; + {-Just like the routine without "Peek", but not destroying the previous + error on success} + + Function BTGetNextUsedAddRecRef ( IFBPtr : IsamFileBlockPtr ) : LongInt; + {-Returns the data reference, that is used for adding the next record; + this function is of a more internal nature} + + Function BTGetAfterNextUsedAddRecRef ( IFBPtr : IsamFileBlockPtr ) : LongInt; + {-Returns the data reference, that is used after adding the next record; + this function is of a more internal nature} + + Function BTGetInternalDialogID ( IFBPtr : IsamFileBlockPtr ) : Word; + {-Returns the internal ID used by network accesss to this fileblock} + + Function BTGetAllowDupKeys ( IFBPtr : IsamFileBlockPtr; {!!.50} + KeyNr : Word ) : Boolean; + {-Returns, whether duplicate keys are allowed or not} + + Function BTGetKeyLen ( IFBPtr : IsamFileBlockPtr; {!!.50} + KeyNr : Word ) : Word; + {-Returns the length of the key string KeyNr} + + Procedure BTNoCharConvert ( DataPtr : Pointer; {!!.50} + DataLen : LongInt; + PostRead : Boolean; + HookPtr : Pointer ); + {-Does nothing} + + Procedure BTSetCharConvert ( IFBPtr : IsamFileBlockPtr; {!!.50} + CCProc : ProcBTCharConvert; + HookPtr : Pointer; + DestrWrite : Boolean ); + {-Sets the routine to convert data fields between different character + sets; the routine CCProc is called after reading a record and before + writing a record; if DestrWrite is true, CCProc is called in addition + after writing a record to reconvert the record} + + Function BTIsInitialized : Boolean; {!!.50} + {-Returns whether B-Tree Isam is currently initialized} + +{--Interfaced only for compatibility reasons; not used outside except + for network tests} + Function BTIsamLockRecord ( Start, + Len : LongInt; + Handle : IsamHandle; + TimeOut, + DelayTime : Word ) : Boolean; + {-Locks the bytes Start to Start+Len-1 of the file + with handle Handle; TimeOut is the maximum wait time which may be + separated in several retries with DelayTime milliseconds} + + Function BTIsamUnLockRecord ( Start, + Len : LongInt; + Handle : IsamHandle) : Boolean; + {-Unlocks the bytes Start to Start+Len-1 of the file + with handle Handle} + + Function BTIsamGetSequentialOK ( IFBPtr : IsamFileBlockPtr; {!!.50} + KeyNr : Word ) : Boolean; + {-Returns, whether sequentiell access for key KeyNr is ok} + +{--Routines of internal nature, but interfaced as well} + Procedure IsamClearOK; + {-Resets all status variables, even internal ones} + + Function IsamExists ( Name : IsamFileName ) : Boolean; + {-Returns True, if the specified file exists} + + Procedure IsamExtractFileNames ( FNameComp : IsamFileBlockName; + Var FNameD, + FNameI : IsamFileBlockName ); + {-Seperates two file names seperated by ";"} + + Procedure IsamCopyFile ( Source, + Dest : IsamFileBlockName; + DeleteSourceAfterCopy : Boolean ); + + {-Copies file Source to Dest} + + Function IsamForceExtension ( Name, Ext : IsamFileName ) : IsamFileName; + {-Forces the extension Ext to the file name Name} + +{$IFNDEF Win32} +{$IFDEF FPC} + Function RoundToGranul ( Value : Word ) : Word; +{$ELSE} +{$IFDEF Heap6} + Function RoundToGranul ( Value : Word ) : Word; + {-Rounds Value up to the next multiple of 8} +{$ELSE} + Function RoundToGranul ( Value : Word ) : Word; + Inline ( $58 ); {pop ax} +{$ENDIF} +{$ENDIF FPC} +{$ENDIF} + + Function IsamGetNumRecAddress ( IFBPtr : IsamFileBlockPtr ) : Pointer; + {-Internal use only!} {!!.50} + + Procedure IsamEntryCode ( IFBPtr : IsamFileBlockPtr; Options : Word ); + {-Internal use only!} {!!.50} + + Procedure IsamExitCode ( IFBPtr : IsamFileBlockPtr ); + {-Internal use only!} {!!.50} + + Procedure IsamAddRec ( IFBPtr : IsamFileBlockPtr; + Var RefNr : LongInt; + Var Source ); + {-Internal use only!} {!!.50} + + Procedure IsamDeleteRec ( IFBPtr : IsamFileBlockPtr; RefNr : LongInt ); + {-Internal use only!} {!!.50} + + Procedure IsamPutRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Source ); + {-Internal use only!} {!!.50} + + Procedure IsamGetRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest ); + {-Internal use only!} {!!.50} + + Procedure IsamGetRecReadOnly ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest ); + {-Internal use only!} {!!.50} + + +{--Internal use only constants} {!!.50mov} +Const + OptCheckLock = $0100; + OptReadPrefix = $0200; + OptKeyRoutine = $0400; + OptWriteRoutine = $0800; {!!.41} + NoOptions = 0; + NotAFileBlockPtr = $FFFFFFFF; + + +Implementation + +{--Privat constants} +Const + IsamFBValidSign = $11195851; + +{--Privat types} +Type + LongPtr = ^LongInt; + + ErrStatSaveRec = packed Record + OK : Boolean; + Error : Integer; + DError, + DFunc : Word; + End; + +{--Privat variables} +Var + IsamRBR1Ptr : IsamRingBufferRecPtr; + IsamOFBLPtr : IsamOpenFileBlockListPtr; + IsamNrOfRingBufferRecs : Word; + IsamDriveNotReadyError, + IsamLockError, + IsamNetEmu, + IsamForceFlushOfMark, + IsamIsCriticalActive, + IsamIsInitialized : Boolean; + + IsamInitializedNet : NetSupportType; + + UserSaveEMSHandle, + OwnSaveEMSHandle : Byte; + EMSHeapIsUsed : Boolean; + + {$I isambase.inc} + {$I isamwork.inc} +{$IFNDEF NoNet} + {$I isamnwrk.inc} +{$ENDIF} + {$I isamlow.inc} + {$I filer.inc} {!!.TP} + +{$IFDEF MSDOS} +Type + IsamINT24DNRHandlerDef = Record + PushAXBX, + PushCXDX, + PushBPSI, + PushDIDS, + PushESF : Word; + AndDIFF1 : LongInt; + CmpDI02 : LongInt; + JzMyTurn : Word; +{ DoOldINT : } + PopFES1, + PopDSDI1, + PopSIBP1, + PopDXCX1, + PopBXAX1 : Word; + NopJmpFar : Word; + OldINT24Addr : Pointer; +{ MyTurn : } + NopMovAX : Word; + SegDNRError : Word; + MovDSAX : Word; + MovByte : Word; + OfsDNRError : Word; + ConstTrueNop : Word; + JmpDoOldInt : Word; + End; + + +Const + IsamINT24DNRHandler : IsamINT24DNRHandlerDef = ( + PushAXBX : $5350; + PushCXDX : $5251; + PushBPSI : $5655; + PushDIDS : $1E57; + PushESF : $9C06; + AndDIFF1 : $00FFE781; + CmpDI02 : $0002FF81; + JzMyTurn : $1074; + + PopFES1 : $079D; + PopDSDI1 : $5F1F; + PopSIBP1 : $5D5E; + PopDXCX1 : $595A; + PopBXAX1 : $585B; + NopJmpFar : $EA90; + OldINT24Addr : Nil; + + NopMovAX : $B890; + SegDNRError : $FFFF; + MovDSAX : $D88E; + MovByte : $06C6; + OfsDNRError : $FFFF; + ConstTrueNop : $9000; + JmpDoOldInt : $E2EB); + + + Procedure IsamInstallInt24DNRHandler; + + Begin + With IsamINT24DNRHandler Do Begin + CallGetIntVec ( $24, OldINT24Addr ); + SegDNRError := Seg (IsamDriveNotReadyError); + OfsDNRError := Ofs (IsamDriveNotReadyError); + ConstTrueNop := ConstTrueNop + Ord (True); + End; + CallSetIntVec ( $24, @IsamINT24DNRHandler ); + End; + + + Procedure IsamRemoveInt24DNRHandler; + + Begin + CallSetIntVec ( $24, IsamINT24DNRHandler.OldINT24Addr ); + End; +{$ENDIF} + + +{!!.54 Initialization and finalization code rewritten} + +{$IFNDEF WIN32} +var + SaveExitProc : Pointer; +{$ENDIF} + +procedure FilerUnitDone; far; {!!.55} +begin + {$IFNDEF WIN32} + ExitProc := SaveExitProc; + {$ENDIF} + if IsamIsInitialized then begin + IsamCloseAllFileBlocks; + IsamClearOK; + end; + {$IFDEF MSDOS} + IsamRemoveInt24DNRHandler; + {$ENDIF} +end; + +procedure FilerUnitInit; +begin + {$IFNDEF Win32} {!!.57} + IsamDelay(1); {!!.57} + {$ENDIF} {!!.57} + {$IFDEF MSDOS} + IsamInstallInt24DNRHandler; + {$ENDIF} + IsamIsInitialized := False; + IsamCompiledNets := [] + {$IFDEF NoNet} + + [NoNet] + {$ENDIF} + {$IFDEF Novell} + + [Novell] + {$ENDIF} + {$IFDEF MsNet} + + [MsNet] + {$ENDIF} + ; + {$IFNDEF Win32} + SaveExitProc := ExitProc; + ExitProc := @FilerUnitDone; + {$ENDIF} +end; + +{$IFDEF Win32} +initialization + FilerUnitInit; +finalization + FilerUnitDone; +{$ELSE} +begin + FilerUnitInit; +{$ENDIF} +end. + diff --git a/src/wc_sdk/fixtovar.pas b/src/wc_sdk/fixtovar.pas new file mode 100644 index 0000000..eb7be6c --- /dev/null +++ b/src/wc_sdk/fixtovar.pas @@ -0,0 +1,110 @@ +{********************************************************************} +{* FIXTOVAR.PAS - Convert fixed-length to variable-length records *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + +Unit FixToVar; + +Interface + +Uses + BTBase, + BTIsBase, + Filer, {!!.TP} + ReStruct, {!!.50} + ReIndex, + VReorg; + + Procedure FixToVarFileBlock ( FBlName : IsamFileBlockName; + DatSLenFix : LongInt; + DatSLenVar : LongInt; + NumberOfKeys : Word; + IID : IsamIndDescr; + BuildKeyFunc : FuncBuildKey ); + {-Builds a variable record length fileblock out of a fixed} + + +Implementation + + Function IsamChangeDatSElongateCheckZ ( Var DatSOld; + Var DatSNew; + Var Len : Word ) : Boolean; far; + {!!.50} + Type + AllArr = Array [0..0] Of Byte; + + Var + Null : LongInt; + + Begin + Null := 0; + Move ( DatSOld, DatSNew, Len ); + Move ( Len, AllArr (DatSNew) [Len], SizeOf (Len) ); + Move ( Null, AllArr (DatSNew) [Len + SizeOf (Word)], + SizeOf (LongInt) ) ; + IsamChangeDatSElongateCheckZ := LongInt (DatSOld) = LongInt (0); + End; + + + Procedure FixToVarFileBlock ( FBlName : IsamFileBlockName; + DatSLenFix : LongInt; + DatSLenVar : LongInt; + NumberOfKeys : Word; + IID : IsamIndDescr; + BuildKeyFunc : FuncBuildKey ); + + Var + IIDDummy : IsamIndDescr; + DatSLenEmulVar : LongInt; + MaxDiffBytes : Word; + + Begin + DatSLenEmulVar := DatSLenFix + SizeOf (Word) + SizeOf (LongInt); + RestructFileBlock ( FBlName, DatSLenEmulVar, DatSLenFix, False, + 0, IsamChangeDatSElongateCheckZ, BTNoCharConvert, Nil ); {!!.50} + If Not IsamOK Then Exit; + If DatSLenVar > DatSLenEmulVar Then Begin + MaxDiffBytes := DatSLenVar - DatSLenEmulVar; + End Else Begin + MaxDiffBytes := 0; + End; + ReorgVFileBlock ( FBlName, DatSLenVar, NumberOfKeys, IID, DatSLenEmulVar, + MaxDiffBytes, BuildKeyFunc, ChangeDatSNoChange ); {!!.50} + End; + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/fvcbrows.pas b/src/wc_sdk/fvcbrows.pas new file mode 100644 index 0000000..00d5f45 --- /dev/null +++ b/src/wc_sdk/fvcbrows.pas @@ -0,0 +1,1767 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * Rob Roberts robr@pcisys.net + * + * ***** END LICENSE BLOCK ***** *) + +{$C MOVEABLE,DEMANDLOAD,DISCARDABLE} + +{--Conditional defines and compiler options that affect this unit} + {$I btdefine.inc} + {$IFNDEF UsingDelphi} + !! This browser requires Delphi + {$ENDIF} + {$X+,F-,V+,B-,S-,I+,R-,Q-} + +unit Fvcbrows; + +interface + +uses + SysUtils, + WinTypes, + WinProcs, + Messages, + Classes, + Graphics, + Controls, + Forms, + Menus, + Dialogs, + BTBase, + BTIsBase, + Filer, + StdCtrls, + LowBrows, + MedBrows, + HiBrows; + +const + HardError = 4; + ProgrammingError = 5; + +type + TFvcBrowser = class; + + PLowWinBrowser = ^TLowWinBrowser; + + TLowWinBrowser = object(BRHBrowser) + Owner : TFvcBrowser; + OnHeap : Boolean; + + constructor Init ( ParOnHeap : Boolean; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + var ADatS; + AIsVarRec : Boolean ); + + destructor Done; virtual; + function BuildRow(var RR : RowRec): Integer; virtual; + function PerformFilter(var RR: RowRec; + var UseIt: Boolean): Integer; virtual; + + procedure ShowErrorOccured(EClass : Integer); virtual; + function PreCompletePage : Integer; virtual; + function PostCompletePage : Integer; virtual; + end; + + TBuildRowEvent = function(Sender: TObject; var RR: RowRec): Integer of object; + + TFilterEvent = function(Sender: TObject; var RR: RowRec; + var UseIt: Boolean): Integer of object; + + TFilterWorkingEvent = procedure(Sender: TObject; CallState: Integer; + Rejected: Boolean) of object; + + TPrePostCompletePage = function(Sender : TObject): Integer of object; + + FontInfo = record + ChHeightExtra, + ChHeight, + ChWidth, + ChRefWidth : Word; + FixedPitch : Boolean; + End; + + TFvcBrowser = class(TCustomControl) + protected {private} + BrowserPtr: PLowWinBrowser; + FilterInProgress: Boolean; + FontDescr: FontInfo; + FirstRow, + FullPage: word; + FBIsClosed : boolean; {!!.54} + FBorderStyle: TBorderStyle; + FFilterEnabled: Boolean; + FDoMouseMove: Boolean; + FFooterColor: TColor; + FFooter: BRLRowEltString; + FFooterTxtColor: TColor; + FHeaderColor: TColor; + FHeader: BRLRowEltString; + FHeaderTxtColor: TColor; + FHighlightColor: TColor; + FHighlightTxtColor: TColor; + FHorizOfs: integer; + FInitDone: Boolean; + FMaxHorizOfs: word; + FNoPaintHFCg: Boolean; + FOnBuildRow: TBuildRowEvent; + FOnFirstUserInit: TNotifyEvent; + FOnPerformFilter: TFilterEvent; + FOnPreCompletePage: TPrePostCompletePage; + FOnPostCompletePage: TPrePostCompletePage; + FOnRowChanged: TNotifyEvent; + FOnShowFilterWorking : TFilterWorkingEvent; + FPosClientCorruption: Boolean; + FScrollBars: TScrollStyle; + FTextMargin: TRect; + FThumbHTrack, + FThumbVTrack: word; + FUseSeparator: Boolean; + FVertScale: word; + function AdjustHorizOfs(Delta : integer): integer; + function BuildRow(var RR: RowRec): integer; + procedure DisplayRow(I: integer; Inverse: Boolean); + procedure EndFilter; + procedure FirstInit; + procedure FirstUserInit; + function GetCurrentKeyNr: word; + function GetHighKey: GenKeyStr; + function GetLowKey: GenKeyStr; + procedure GetRowAreaRect(var Rect: TRect); + procedure InvalidateBrowserScreen; + procedure JustFiltered(Rejected: Boolean); + procedure lwNewSize; + procedure lwSetAndUpdateBrowserScreen(NewKeyStr: GenKeyStr; NewRef: LongInt); + procedure lwUpdateBrowserScreen; + procedure lwUpdateHorzScrollBar; + procedure lwUpdateVertScrollBar; + procedure NewSize; + function PerformFilter(var RR: RowRec; var UseIt: Boolean): integer; + function PreCompletePage: integer; + function PostCompletePage: integer; + procedure RowChanged; + procedure SetBorderStyle(Value: TBorderStyle); + procedure SetCharValues; + procedure SetFilterEnabled(Value: Boolean); + procedure SetFooter(Value: BRLRowEltString); + procedure SetFooterColor(Value: TColor); + procedure SetFooterTxtColor(Value: TColor); + procedure SetHeader(Value: BRLRowEltString); + procedure SetHeaderColor(Value: TColor); + procedure SetHeaderTxtColor(Value: TColor); + procedure SetHighKey(Value: GenKeyStr); + procedure SetHighlightColor(Value: TColor); + procedure SetHighlightTxtColor(Value: TColor); + procedure SetHorizOfs(Value: integer); + procedure SetKeyNr(Value: Word); + procedure SetLowKey(Value: GenKeyStr); + procedure SetUseSeparator(Value: Boolean); + procedure ShowFilterWorking(CallState: Integer; Rejected: Boolean); virtual; + function TotalSpaceForLines(Rect : TRect): Word; + procedure CMFontChanged(var Message: TMessage); {!!.52} + message CM_FONTCHANGED; {!!.52} + procedure WMGetDlgCode(var Msg: TWMGetDlgCode); + message WM_GETDLGCODE; + procedure WMHScroll(var Msg: TWMHScroll); + message WM_HSCROLL; + procedure WMKillFocus(var Msg: TWMKillFocus); + message WM_KILLFOCUS; + {$IFDEF Delphi4Plus} {!!.57} + procedure CMMouseWheel(var Msg: TCMMouseWheel); {!!.57} + message CM_MOUSEWHEEL; {!!.57} + {$ENDIF} {!!.57} + procedure WMNCMouseMove(var Msg: TWMNCMouseMove); + message WM_NCMOUSEMOVE; + procedure WMSize(var Msg: TWMSize); + message WM_SIZE; + procedure WMVScroll(var Msg: TWMVScroll); + message WM_VSCROLL; + protected + function CanCallLowBrowser: Boolean; virtual; + function ClientPosCorrupted: Boolean; virtual; + procedure CreateParams(var Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DrawSeparator(Pos: word); virtual; + procedure EraseRowAreaRect; virtual; + procedure GetBrowserTextRect(var TextRect : TRect); virtual; + function GetLineNrFromY(Y : Integer): word; virtual; + function GetTextOutPosY(LineNr: word): integer; virtual; + function GetVersion: string; {!!.56} + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyPress(var Key: Char); override; + procedure MarkClientCorruptablePhase; virtual; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + procedure MoveToHorizPos(Pos : Word); virtual; + procedure MoveToRelPos(Pos : Word); virtual; + procedure Paint; override; + procedure Reinit; virtual; + procedure RightHome; virtual; + procedure SetMargins; dynamic; + procedure SetVersion(const Value: string); {!!.56} + procedure ShowErrorOccured(EClass: Integer); virtual; + procedure WriteDataLine(var DataLine: BRLRowEltString; LineNr: Word); virtual; + procedure WriteFooter; virtual; + procedure WriteHeader; virtual; + function WriteStringOut(var S : BRLRowEltString; + LineNr : word; + XOfs : integer): word; virtual; + function XYPosInRect(X, Y: Integer; Rect: TRect): Boolean; + public + function BuildBrowScreenRow(var RR : RowRec): integer; virtual; + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; {!!.52} + function CalcMaxWidth: Integer; virtual; + function ConnectLowBrowser(ABrowserPtr: PLowWinBrowser): Boolean; virtual; + function GetCurrentDatRef: LongInt; + function GetCurrentKeyStr: string; + function GetCurNrOfLines: word; + function GetCurrentRec(var Match: Boolean): integer; + function GetThisRec(var RR : RowRec): integer; + procedure FirstPage; virtual; {!!.52} + procedure LastPage; virtual; {!!.52} + procedure LeftHome; virtual; {!!.52} + procedure LineDown; virtual; {!!.52} + procedure LineLeft; virtual; {!!.52} + procedure LineRight; virtual; {!!.52} + procedure LineUp; virtual; {!!.52} + procedure PageDown; virtual; {!!.52} + procedure PageLeft; virtual; {!!.52} + procedure PageRight; virtual; {!!.52} + procedure PageUp; virtual; {!!.52} + procedure PosClientCorruption; + procedure SetAndUpdateBrowserScreen(NewKeyStr: GenKeyStr; NewRef: LongInt); + procedure SetKeys(KeyNr : Word; Low, High : GenKeyStr); {!!.52} + function TotalCharHeight : Word; + procedure UpdateBrowserScreen; + + procedure FileblockHasClosed; {!!.54} + + property Canvas; + + property HighKey: GenKeyStr + read GetHighKey + write SetHighKey; + + property KeyNumber: Word + read GetCurrentKeyNr + write SetKeyNr; + + property LowKey: GenKeyStr + read GetLowKey + write SetLowKey; + + published + + property Align; + + property BorderStyle: TBorderStyle + read FBorderStyle + write SetBorderStyle + default bsSingle; + + property Color + default clWindow; + + property Ctl3D; + + property Enabled; + + property FilterEnabled: Boolean + read FFilterEnabled + write SetFilterEnabled + default False; + + property Font; + + property Footer: BRLRowEltString + read FFooter + write SetFooter; + + property FooterColor: TColor + read FFooterColor + write SetFooterColor + default clBtnFace; + + property FooterTxtColor: TColor + read FFooterTxtColor + write SetFooterTxtColor + default clBtnText; + + property Header: BRLRowEltString + read FHeader + write SetHeader; + + property HeaderColor: TColor + read FHeaderColor + write SetHeaderColor + default clBtnFace; + + property HeaderTxtColor: TColor + read FHeaderTxtColor + write SetHeaderTxtColor + default clBtnText; + + property HighlightColor: TColor + read FHighlightColor + write SetHighlightColor + default clHighlight; + + property HighlightTxtColor: TColor + read FHighlightTxtColor + write SetHighlightTxtColor + default clHighlightText; + + property HorizOfs: integer + read FHorizOfs + write SetHorizOfs + default 0; + + property OnBuildRow: TBuildRowEvent + read FOnBuildRow + write FOnBuildRow; + + property OnDblClick; + + property OnEnter; + + property OnExit; + + property OnFirstUserInit: TNotifyEvent + read FOnFirstUserInit + write FOnFirstUserInit; + + property OnKeyDown; + + property OnKeyPress; + + property OnKeyUp; + + property OnMouseDown; + + property OnMouseMove; + + property OnMouseUp; + + property OnPerformFilter: TFilterEvent + read FOnPerformFilter + write FOnPerformFilter; + + property OnPreCompletePage: TPrePostCompletePage + read FOnPreCompletePage + write FOnPreCompletePage; + + property OnPostCompletePage: TPrePostCompletePage + read FOnPostCompletePage + write FOnPostCompletePage; + + property OnRowChanged: TNotifyEvent + read FOnRowChanged + write FOnRowChanged; + + property OnShowFilterWorking: TFilterWorkingEvent + read FOnShowFilterWorking + write FOnShowFilterWorking; + + property ParentColor; + + property ParentCtl3D; + + property ParentFont; + + property ParentShowHint; + + property PopupMenu; + + property ShowHint; + + property TabOrder; + + property TabStop; + + property UseSeparator: Boolean + read FUseSeparator + write SetUseSeparator + default True; + + property Version: string {!!.56} + read GetVersion + write SetVersion; + + property Visible; + end; + +implementation + +const + VertScrollScale = 63; + +constructor TLowWinBrowser.Init + ( ParOnHeap : Boolean; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + var ADatS; + AIsVarRec : Boolean ); +begin + Owner := nil; + OnHeap := ParOnHeap; + if not BRHBrowser.Init(ADrvOrFileBlockPtr, ANumberOfEltsPerRow, + ANumberOfRows, ALKey, AHKey, False, ADatS, AIsVarRec) then Fail; + KeyNr := AKeynr; +end; + +destructor TLowWinBrowser.Done; +begin + {inherited Done;} {!!.52} + BRHBrowser.Done; + if Assigned(Owner) then + Owner.BrowserPtr := nil; + Owner := nil; +end; + +function TLowWinBrowser.BuildRow (var RR : RowRec): Integer; +begin + Result := Owner.BuildRow(RR); +end; + +function TLowWinBrowser.PerformFilter (var RR : RowRec; + var UseIt : Boolean): Integer; +begin + Result := Owner.PerformFilter(RR, UseIt); + if (Result = NoError) and Owner.FilterEnabled then begin + Owner.JustFiltered (not UseIt); + end; +end; + +function TLowWinBrowser.PostCompletePage: Integer; +begin + Result := Owner.PostCompletePage; + Owner.EndFilter; +end; + +function TLowWinBrowser.PreCompletePage: Integer; +begin + Result := Owner.PreCompletePage; +end; + +procedure TLowWinBrowser.ShowErrorOccured (EClass : Integer); +begin + Owner.ShowErrorOccured (EClass); + Owner.EndFilter; +end; + +(************************************************************************) + +function GetLeftButton: Byte; +const + RLButton : array[Boolean] of Word = (VK_LBUTTON, VK_RBUTTON); +begin + Result := RLButton[GetSystemMetrics(SM_SWAPBUTTON) <> 0]; +end; + +constructor TFvcBrowser.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ControlStyle := [csCaptureMouse, csFramed, csOpaque, csDoubleClicks]; + FInitDone := False; + BrowserPtr := nil; + FScrollBars := ssBoth; + FBorderStyle := bsSingle; + Color := clWindow; + FDoMouseMove := False; + FFilterEnabled := False; + FFooterColor := clBtnFace; + FFooterTxtColor := clBtnText; + FHeaderColor := clBtnFace; + FHeaderTxtColor := clBtnText; + FHighlightColor := clHighlight; + FHighlightTxtColor := clHighlightText; + FHorizOfs := 0; + FUseSeparator := True; + ParentColor := False; + Height := 100; + Width := 200; +end; + +destructor TFvcBrowser.Destroy; {!!.52} +begin {!!.52} + if Assigned(BrowserPtr) then {!!.52} + if BrowserPtr^.OnHeap then {!!.52} + Dispose(BrowserPtr, Done) {!!.52} + else {!!.52} + BrowserPtr^.Done; {!!.52} + BrowserPtr := nil; {!!.52} + inherited Destroy; {!!.52} +end; {!!.52} + +procedure TFvcBrowser.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); + with Params do + begin + if FBorderStyle = bsSingle then Style := Style or WS_BORDER; + if FScrollBars in [ssVertical, ssBoth] then Style := Style or WS_VSCROLL; + if FScrollBars in [ssHorizontal, ssBoth] then Style := Style or WS_HSCROLL; + end; +end; + +procedure TFvcBrowser.CreateWnd; +begin + inherited CreateWnd; + if Assigned(BrowserPtr) then FirstInit; +end; + +function TFvcBrowser.AdjustHorizOfs(Delta : integer): integer; +var + Offset : LongInt; +begin + Offset := LongInt(FHorizOfs) + Delta; + if Offset < 0 then begin + Offset := 0; + end else begin + if OffSet > FMaxHorizOfs then begin + Offset := FMaxHorizOfs; + end; + end; + Result := Offset; +end; + +function TFvcBrowser.BuildBrowScreenRow(var RR : RowRec): integer; +begin + Result := ProgrammingError; + if BrowserPtr = nil then Exit; + Result := BrowserPtr^.BuildBrowScreenRow(RR); +end; + +function TFvcBrowser.BuildRow(var RR: RowRec): integer; +begin + if Assigned(FOnBuildRow) then + Result := FOnBuildRow(Self, RR) + else begin + RR.Row := 'You do not have an OnBuildRow event defined'; + Result := NoError; + end; +end; + +function TFvcBrowser.CalcMaxWidth : Integer; +begin + Result := MaxCols * FontDescr.ChWidth; +end; + +function TFvcBrowser.CanCallLowBrowser: Boolean; +begin + {rewritten !!.54} + Result := Assigned(BrowserPtr) and FInitDone and IsWindow(Handle) + and BrowserPtr^.BrowserCallAllowed and (not FilterInProgress) and + (not FBIsClosed); +end; + +function TFvcBrowser.ClientPosCorrupted: Boolean; +begin + Result := FPosClientCorruption; +end; + +function TFvcBrowser.ConnectLowBrowser(ABrowserPtr: PLowWinBrowser): Boolean; +begin + Result := False; + FInitDone := False; + if not Assigned(ABrowserPtr) then Exit; + if Assigned(BrowserPtr) then begin + if BrowserPtr^.OnHeap then begin + Dispose (BrowserPtr, Done); + end else begin + BrowserPtr^.Done; + end; + end; + BrowserPtr := ABrowserPtr; + BrowserPtr^.Owner := Self; + FirstInit; + Result := True; +end; + +procedure TFvcBrowser.DisplayRow(I: Integer; Inverse: Boolean); +begin + Canvas.Brush.Color := Color; + Canvas.Font.Color := Font.Color; + + if Inverse then begin + Canvas.Brush.Color := FHighlightColor; + Canvas.Font.Color := FHighlightTxtColor; + end; + WriteDataLine (BrowserPtr^.BSAPtr^ [I]^.Row, I); + if I = 1 then begin + if ClientPosCorrupted or not FNoPaintHFCg then begin + MarkClientCorruptablePhase; + if (FHeader <> '') or (FFooter <> '') then begin + if FHeader <> '' then begin + Canvas.Brush.Color := FHeaderColor; + Canvas.Font.Color := FHeaderTxtColor; + WriteHeader; + end; + if FFooter <> '' then begin + Canvas.Brush.Color := FFooterColor; + Canvas.Font.Color := FFooterTxtColor; + WriteFooter; + end; + end + end else begin + if BrowserPtr^.GetCurRow <> 1 then FNoPaintHFCg := False; + end; + end; +end; + +procedure TFvcBrowser.DrawSeparator(Pos: word); +var + TR : TRect; +begin + GetBrowserTextRect(TR); + Canvas.MoveTo(TR.Left, Pos); + Canvas.LineTo(TR.Right, Pos); +end; + +procedure TFvcBrowser.EndFilter; +begin + if FilterInProgress then begin + {FilterInProgress := False;} {!!.53} + ShowFilterWorking(1, False); + FilterInProgress := False; {!!.53} + {InvalidateBrowserScreen; removed !!.54} {!!.53} + end; +end; + +procedure TFvcBrowser.EraseRowAreaRect; +var + Rect : TRect; +begin + Rect.Top := GetTextOutPosY(1); + Rect.Bottom := Rect.Top + TotalCharHeight * FullPage; + Rect.Left := FTextMargin.Left; + Rect.Right := Rect.Left + Width; + InvalidateRect(Handle, @Rect, True); +end; + +procedure TFvcBrowser.FirstInit; +begin + if FInitDone then Exit; + if not HandleAllocated then Exit; + SetMargins; + Reinit; + {BrowserPtr^.SetNrOfRows(FullPage);} {!!.52} + FVertScale := VertScrollScale; + FThumbVTrack := $FFFF; + FThumbHTrack := $FFFF; + if FScrollBars in [ssHorizontal, ssBoth] then begin + SetScrollRange (Handle, SB_Horz, 0, FMaxHorizOfs, True); + end; + if FScrollBars in [ssVertical, ssBoth] then begin + SetScrollRange (Handle, SB_Vert, 0, FVertScale, True); + end; + FInitDone := True; + FirstUserInit; +end; + +procedure TFvcBrowser.FirstPage; +var + BST : BrowScreenState; + Update, + Changed : Boolean; +begin + Update := False; + with BrowserPtr^ do begin + GetBrowScreenState(BST); + HBuildFirstPage(Changed); + if StatusOK then begin + if Changed or BrowScreenStateChanged(BST) then begin + InvalidateBrowserScreen; + Update := True; + end; + end; + end; + if Update then lwUpdateVertScrollBar; +end; + +procedure TFvcBrowser.FirstUserInit; +begin + if Assigned(FOnFirstUserInit) then FOnFirstUserInit(Self); +end; + +procedure TFvcBrowser.GetBrowserTextRect(var TextRect : TRect); +begin + TextRect := GetClientRect; + Inc(TextRect.Left, FTextMargin.Left); + Inc(TextRect.Top, FTextMargin.Top); + Dec(TextRect.Right, FTextMargin.Right); + if TextRect.Right < TextRect.Left then begin + TextRect.Right := TextRect.Left; + end; + Dec(TextRect.Bottom, FTextMargin.Bottom); + {if TextRect.Bottom < TextRect.Bottom then begin} {!!.53} + {TextRect.Bottom := TextRect.Bottom;} {!!.53} + if TextRect.Bottom < TextRect.Top then begin {!!.53} + TextRect.Bottom := TextRect.Top; {!!.53} + end; +end; + +function TFvcBrowser.GetCurrentDatRef : LongInt; +begin + Result := 0; + if not CanCallLowBrowser then Exit; + Result := BrowserPtr^.GetCurrentDatRef; +end; + +function TFvcBrowser.GetCurrentKeyNr : Word; +begin + Result := $FFFF; + if BrowserPtr = nil then Exit; + Result := BrowserPtr^.KeyNr; +end; + +function TFvcBrowser.GetCurrentKeyStr: string; +begin + Result := ''; + if not CanCallLowBrowser then Exit; + Result := BrowserPtr^.GetCurrentKeyStr; +end; + +function TFvcBrowser.GetHighKey: GenKeyStr; +begin + Result := ''; + if not CanCallLowBrowser then Exit; + Result := BrowserPtr^.HighKey; +end; + +function TFvcBrowser.GetLowKey: GenKeyStr; +begin + Result := ''; + if not CanCallLowBrowser then Exit; + Result := BrowserPtr^.LowKey; +end; + +function TFvcBrowser.GetLineNrFromY(Y : Integer): Word; +begin + Result := (Y - FTextMargin.Top) div TotalCharHeight + 2 - FirstRow; +end; + +function TFvcBrowser.GetCurrentRec(var Match : Boolean): integer; +begin + Match := False; + Result := ProgrammingError; + if not CanCallLowBrowser then Exit; + with BrowserPtr^ do begin + Result := GetRowMatchingRec(BSAPtr^[GetCurRow]^, True, True, Match); + end; +end; + +function TFvcBrowser.GetCurNrOfLines : Word; +begin + Result := FullPage; +end; + +procedure TFvcBrowser.GetRowAreaRect(var Rect : TRect); +var + Lines : Word; +begin + Rect.Top := GetTextOutPosY(1); + if Assigned(BrowserPtr) then begin + Lines := BrowserPtr^.GetLastRow; + end else begin + Lines := FullPage; + end; + Rect.Bottom := Rect.Top + TotalCharHeight * Lines; + Rect.Left := FTextMargin.Left; + Rect.Right := Rect.Left + Width; +end; + +function TFvcBrowser.GetTextOutPosY(LineNr: word): integer; +var + TR: TRect; +begin + Result := (LineNr + FirstRow - 2) * TotalCharHeight + FTextMargin.Top; + if LineNr > FullPage then begin + TR := GetClientRect; + Result := TR.Bottom - TotalCharHeight - FontDescr.ChHeightExtra + - FTextMargin.Bottom; + end; +end; + +function TFvcBrowser.GetVersion: string; {!!.56 - new} +begin + Result := VersionStr; +end; + +function TFvcBrowser.GetThisRec(var RR : RowRec): integer; +begin + Result := ProgrammingError; + if BrowserPtr = nil then Exit; + Result := BrowserPtr^.BRGetRec(RR, False, False); +end; + +procedure TFvcBrowser.InvalidateBrowserScreen; +begin + FNoPaintHFCg := False; + InvalidateRect(Handle, nil, False); +end; + +procedure TFvcBrowser.JustFiltered(Rejected: Boolean); +begin + if FilterInProgress then begin {!!.52} + ShowFilterWorking (0, Rejected); {!!.52} + end else begin {!!.52} + FilterInProgress := True; {!!.52} + ShowFilterWorking ( -1, Rejected ); {!!.52} + end; {!!.52} +end; + +procedure TFvcBrowser.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited KeyDown(Key, Shift); + if CanCallLowBrowser then begin + if ssCtrl in Shift then + case Key of + vk_Home : FirstPage; + vk_End : LastPage; + vk_Right : PageRight; + vk_Left : PageLeft; + end else + case Key of + vk_Down : LineDown; + vk_Up : LineUp; + vk_Next : PageDown; + vk_Prior : PageUp; + vk_Home : LeftHome; + vk_End : RightHome; + vk_Right : LineRight; + vk_Left : LineLeft; + end; + end; +end; + +procedure TFvcBrowser.KeyPress(var Key: Char); +begin + inherited KeyPress(Key); + if not CanCallLowBrowser then Exit; + case UpCase(Key) of + '0'..'9', 'A'..'Z', '', '', '', '', '', '', '' : begin + SetAndUpdateBrowserScreen((Key), 0); + end; + '+' : UpdateBrowserScreen; + end; +end; + +procedure TFvcBrowser.LastPage; +var + BST : BrowScreenState; + Update, + Changed : Boolean; +begin + Update := False; + with BrowserPtr^ do begin + GetBrowScreenState(BST); + HBuildLastPage(Changed); + if StatusOK then begin + if Changed or BrowScreenStateChanged(BST) then begin + InvalidateBrowserScreen; + Update := True; + end; + end; + end; + if Update then lwUpdateVertScrollBar; +end; + +procedure TFvcBrowser.LeftHome; +var + OldHOfs : Integer; +begin + OldHOfs := FHorizOfs; + FHorizOfs := AdjustHorizOfs(-FHorizOfs); + if OldHOfs <> FHorizOfs then begin + InvalidateBrowserScreen; + lwUpdateHorzScrollBar; + end; +end; + +procedure TFvcBrowser.LineDown; +var + LRow : Word; + Moved : Word; + CR : Word; + R : TRect; + Dummy, + Update : Boolean; + TRR : RowRec; +begin + Update := True; + FNoPaintHFCg := True; + with BrowserPtr^ do begin + LRow := GetLastRow; + CR := GetCurRow; + if (CR = LRow) or (LRow = 0) then begin + MarkClientCorruptablePhase; + HBuildNextPage(1, Moved, True, 0, Dummy); + if StatusOK then begin + if OtherAction then begin + InvalidateBrowserScreen; + end else begin + if Moved = 1 then begin + if FullPage <> 1 then begin + if LRow = GetLastRow then begin + if ClientPosCorrupted then begin + InvalidateBrowserScreen; + end else begin + GetRowAreaRect(R); + Dec(R.Bottom, FontDescr.ChHeightExtra); + CopyRowRec(BSAPtr^ [LRow]^, TRR); + CopyRowRec(BSAPtr^ [Pred (LRow)]^, BSAPtr^ [LRow]^); + DisplayRow(LRow, False); + CopyRowRec(TRR, BSAPtr^ [LRow]^); + {-Copy RowRec to avoid scrolling the highlight bar} + ScrollWindow(Handle, 0, -TotalCharHeight, @R, @R); + ValidateRect(Handle, nil); + end; + end else begin + SetCurRow(Succ(CR)); + DisplayRow(LRow, False); + end; + end; + DisplayRow(GetCurRow, True); + end else begin + Update := False; + end; + end; + end else begin + Update := False; + end; + end else begin + DisplayRow(CR, False); + SetCurRow(Succ(CR)); + DisplayRow(GetCurRow, True); + end; + end; + if Update then lwUpdateVertScrollBar; +end; + +procedure TFvcBrowser.LineUp; +var + Moved : Word; + CR : Word; + R : TRect; + Dummy, + Update : Boolean; + TRR : RowRec; +begin + Update := True; + FNoPaintHFCg := True; + with BrowserPtr^ do begin + CR := GetCurRow; + if CR = 1 then begin + MarkClientCorruptablePhase; + HBuildPrevPage(1, Moved, True, 0, Dummy); + if StatusOK then begin + if OtherAction then begin + InvalidateBrowserScreen; + end else begin + if Moved = 1 then begin + if FullPage <> 1 then begin + if ClientPosCorrupted then begin + InvalidateBrowserScreen; + end else begin + GetRowAreaRect(R); + Dec(R.Bottom, FontDescr.ChHeightExtra); + CopyRowRec(BSAPtr^ [1]^, TRR); + CopyRowRec(BSAPtr^ [2]^, BSAPtr^ [1]^); + DisplayRow(1, False); + CopyRowRec(TRR, BSAPtr^ [1]^); + {-Copy RowRec to avoid scrolling the highlight bar} + ScrollWindow(Handle, 0, TotalCharHeight, @R, @R); + ValidateRect(Handle, nil); + end; + end; + DisplayRow(1, True); + end else begin + Update := False; + end; + end; + end else begin + Update := False; + end; + end else begin + DisplayRow(CR, False); + SetCurRow(Pred(CR)); + FNoPaintHFCg := True; + DisplayRow(GetCurRow, True); + end; + end; + if Update then lwUpdateVertScrollBar; +end; + +procedure TFvcBrowser.LineRight; +var + OldHOfs : Integer; +begin + OldHOfs := FHorizOfs; + FHorizOfs := AdjustHorizOfs(FontDescr.ChWidth); + if OldHOfs <> FHorizOfs then begin + InvalidateBrowserScreen; + lwUpdateHorzScrollBar; + end; +end; + +procedure TFvcBrowser.LineLeft; +var + OldHOfs : Integer; +begin + OldHOfs := FHorizOfs; + FHorizOfs := AdjustHorizOfs(-FontDescr.ChWidth); + if OldHOfs <> FHorizOfs then begin + InvalidateBrowserScreen; + lwUpdateHorzScrollBar; + end; +end; + +procedure TFvcBrowser.lwNewSize; +var + OldNrOfRows : Word; +begin + OldNrOfRows := FullPage; + Reinit; + with BrowserPtr^ do begin + if OldNrOfRows > FullPage then begin + HShrinkPage(FullPage); + end else begin + if OldNrOfRows < FullPage then begin + HExpandPage(FullPage); + end; + end; + end; + InvalidateBrowserScreen; +end; + +procedure TFvcBrowser.lwSetAndUpdateBrowserScreen (NewKeyStr : GenKeyStr; + NewRef : LongInt ); +begin + with BrowserPtr^ do begin + HBuildNewPage(KeyNr, NewKeyStr, NewRef, GetCurRow, NrOfRows); + {InvalidateBrowserScreen;} {!!.52} + EraseRowAreaRect; {!!.52} + if StatusOK then lwUpdateVertScrollBar; + end; +end; + +procedure TFvcBrowser.lwUpdateBrowserScreen; +var + Changed : Boolean; +begin + with BrowserPtr^ do begin + HBuildThisPage(Changed); + if Changed then begin + EraseRowAreaRect; {!!.52} + InvalidateBrowserScreen; + if StatusOK then lwUpdateVertScrollBar; + end; + end; +end; + +procedure TFvcBrowser.lwUpdateHorzScrollBar; +begin + if FMaxHorizOfs > 0 then begin + if FScrollBars in [ssHorizontal, ssBoth] then begin {!!.53} + SetScrollPos(Handle, SB_Horz, FHorizOfs, True); + end; + end; +end; + +procedure TFvcBrowser.lwUpdateVertScrollBar; +var + RelPos : Word; +begin + RowChanged; + BrowserPtr^.HGetApprRelPos(RelPos, FVertScale, GetCurrentKeyStr, + GetCurrentDatRef); + if not BrowserPtr^.StatusOK then RelPos := 0; + if FScrollBars in [ssVertical, ssBoth] then begin + SetScrollPos(Handle, SB_Vert, RelPos, True); + end; +end; + +procedure TFvcBrowser.MarkClientCorruptablePhase; +begin + FPosClientCorruption := False; +end; + +procedure TFvcBrowser.MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +var + OldCurrow : Integer; + Rect : TRect; +begin + if not (csDesigning in ComponentState) and CanFocus then + begin + SetFocus; + if ValidParentForm(Self).ActiveControl <> Self then + begin + MouseCapture := False; + Exit; + end; + end; + if (Button = mbLeft) and (ssDouble in Shift) then + DblClick + else if Button = mbLeft then + begin + if not CanCallLowBrowser then Exit; + OldCurRow := BrowserPtr^.GetCurRow; + if OldCurRow <> 0 then begin + GetRowAreaRect(Rect); + if not XYPosInRect(X, Y, Rect) then Exit; + BrowserPtr^.SetCurRow(GetLineNrFromY(Y)); + if (OldCurRow <> BrowserPtr^.GetCurRow) + and (BrowserPtr^.GetCurRow <> 0) then begin + DisplayRow(OldCurRow, False); + DisplayRow(BrowserPtr^.GetCurRow, True); + lwUpDateVertScrollBar; + end; + end; + end; + inherited MouseDown(Button, Shift, X, Y); +end; + +procedure TFvcBrowser.MouseMove(Shift: TShiftState; X, Y: Integer); +var + OldCurRow : Integer; + Rect : TRect; + CPos, SPos : TPoint; + LButton : Byte; +const + Scrolling : Boolean = False; +begin + if Scrolling then Exit; + if not FDoMouseMove then begin + if GetFocus = Handle then FDoMouseMove := True; + Exit; + end; + if CanCallLowBrowser then begin + if ssLeft in Shift then begin + with BrowserPtr^ do begin + OldCurRow := GetCurRow; + if OldCurRow <> 0 then begin + GetRowAreaRect(Rect); + if not XYPosInRect(X, Y, Rect) then begin + LButton := GetLeftButton; + Scrolling := True; + repeat + GetCursorPos(SPos); + CPos := ScreenToClient(SPos); + if CPos.Y > Rect.Bottom then Linedown; + if CPos.Y < Rect.Top then LineUp; + Application.ProcessMessages; + until (GetAsyncKeyState(LButton) and $8000 = 0) or + XYPosInRect(CPos.X, CPos.Y, Rect); + Scrolling := False; + end else begin + SetCurRow(GetLineNrFromY(Y)); + if GetCurRow > GetLastRow then begin + SetCurRow(GetLastRow); + end; + if (OldCurRow <> GetCurRow) and (GetCurRow <> 0) then begin + FNoPaintHFCg := True; + DisplayRow(OldCurRow, False); + FNoPaintHFCg := True; + DisplayRow(CurRow, True); + lwUpdateVertScrollBar; + end; + end; + end; + end; + end; + end; + inherited MouseMove(Shift, X, Y); +end; + +procedure TFvcBrowser.MoveToHorizPos(Pos: Word); +var + OldHOfs : Integer; +begin + OldHOfs := FHorizOfs; + FHorizOfs := Pos; + FHorizOfs := AdjustHorizOfs(0); + if OldHOfs <> FHorizOfs then begin + InvalidateBrowserScreen; + lwUpdateHorzScrollBar; + end; +end; + +procedure TFvcBrowser.MoveToRelPos(Pos: Word); +var + Key : GenKeyStr; + Ref : LongInt; +begin + FNoPaintHFCg := True; + BrowserPtr^.HGetApprKeyAndRef(Pos, FVertScale, Key, Ref); + SetAndUpdateBrowserScreen(Key, Ref); + lwUpdateVertScrollBar; {!!.52} + FNoPaintHFCg := False; {!!.53} +end; + +procedure TFvcBrowser.NewSize; +begin + if CanCallLowBrowser then begin + lwNewSize; + end; +end; + +procedure TFvcBrowser.PageDown; +var + BST : BrowScreenState; + Moved : Word; + Update, + Changed : Boolean; +begin + Update := False; + with BrowserPtr^ do begin + GetBrowScreenState(BST); + HBuildNextPage(FullPage, Moved, True, 1, Changed); + if StatusOK then begin + if OtherAction or (Moved > 0) or Changed + or BrowScreenStateChanged(BST) then begin + InvalidateBrowserScreen; + Update := True; + end; + end; + end; + if Update then lwUpdateVertScrollBar; +end; + + +procedure TFvcBrowser.PageUp; +var + BST : BrowScreenState; + Moved : Word; + Update, + Changed : Boolean; +begin + Update := False; + with BrowserPtr^ do begin + GetBrowScreenState(BST); + HBuildPrevPage(FullPage, Moved, True, 1, Changed); + if StatusOK then begin + if OtherAction or (Moved > 0) or Changed + or BrowScreenStateChanged(BST) then begin + InvalidateBrowserScreen; + Update := True; + end; + end; + end; + if Update then lwUpdateVertScrollBar; +end; + +procedure TFvcBrowser.PageRight; +var + OldHOfs : Integer; +begin + OldHOfs := FHorizOfs; + FHorizOfs := AdjustHorizOfs(FontDescr.ChWidth * 10); + if OldHOfs <> FHorizOfs then begin + InvalidateBrowserScreen; + lwUpdateHorzScrollBar; + end; +end; + +procedure TFvcBrowser.PageLeft; +var + OldHOfs : Integer; +begin + OldHOfs := FHorizOfs; + FHorizOfs := AdjustHorizOfs(-FontDescr.ChWidth * 10); + if OldHOfs <> FHorizOfs then begin + InvalidateBrowserScreen; + lwUpdateHorzScrollBar; + end; +end; + +function TFvcBrowser.PerformFilter(var RR: RowRec; + var UseIt: Boolean): integer; +begin + if Assigned(FOnPerformFilter) and FFilterEnabled then + Result := FOnPerformFilter(Self, RR, UseIt) + else begin + UseIt := True; + Result := NoError; + end; +end; + +function TFvcBrowser.PreCompletePage: integer; +begin + if Assigned(FOnPreCompletePage) then + Result := FOnPreCompletePage(Self) + else Result := NoError; +end; + +procedure TFvcBrowser.PosClientCorruption; +begin + FPosClientCorruption := True; +end; + +function TFvcBrowser.PostCompletePage: integer; +begin + if Assigned(FOnPostCompletePage) then + Result := FOnPostCompletePage(Self) + else Result := NoError; +end; + +procedure TFvcBrowser.Reinit; +var + R : TRect; + MaxWidth : Word; +begin + SetCharValues; + {--Horizontal stuff in pixels} {!!.52 Moved from end of method} + MaxWidth := CalcMaxWidth; + if Width > MaxWidth then begin + FMaxHorizOfs := 0; + end else begin + FMaxHorizOfs := MaxWidth - Width; + end; + FHorizOfs := AdjustHorizOfs(0); + if FScrollBars in [ssHorizontal, ssBoth] then begin + SetScrollRange (Handle, SB_Horz, 0, FMaxHorizOfs, False); + SetScrollPos (Handle, SB_Horz, FHorizOfs, True); + end; + {--Get Rectangle to use} + GetBrowserTextRect(R); + {--Vertical stuff in rows} + FullPage := TotalSpaceForLines(R) div TotalCharHeight; + FirstRow := 1; + if FHeader <> '' then begin + Dec (FullPage); + Inc (FirstRow); + end; + if FFooter <> '' then Dec (FullPage); + if (FullPage > $FFF0) or (FullPage = 0) then FullPage := 1; + {-Holds functionality of this browser when resized below 1} + BrowserPtr^.SetNrOfRows(FullPage); {!!.52} +(* {--Horizontal stuff in pixels} {!!.52 Moved to beginning of method} + MaxWidth := CalcMaxWidth; + if Width > MaxWidth then begin + FMaxHorizOfs := 0; + end else begin + FMaxHorizOfs := MaxWidth - Width; + end; + FHorizOfs := AdjustHorizOfs(0); + if FScrollBars in [ssHorizontal, ssBoth] then begin + SetScrollRange (Handle, SB_Horz, 0, FMaxHorizOfs, False); + SetScrollPos (Handle, SB_Horz, FHorizOfs, True); + end; *) +end; + +procedure TFvcBrowser.RightHome; +var + OldHOfs : Integer; +begin + OldHOfs := FHorizOfs; + FHorizOfs := AdjustHorizOfs(FMaxHorizOfs - FHorizOfs); + if OldHOfs <> FHorizOfs then begin + InvalidateBrowserScreen; + lwUpdateHorzScrollBar; + end; +end; + +procedure TFvcBrowser.RowChanged; +begin + if Assigned(FOnRowChanged) then FOnRowChanged(Self); +end; + +procedure TFvcBrowser.SetAndUpdateBrowserScreen( NewKeyStr : GenKeyStr; + NewRef : LongInt ); +begin + if CanCallLowBrowser then begin + lwSetAndUpdateBrowserScreen ( NewKeyStr, NewRef ); + end; +end; + +procedure TFvcBrowser.SetCharValues; +var + TM: TTextMetric; +begin + with FontDescr do begin + ChHeight := 1; + ChWidth:= 1; + ChRefWidth := 1; + ChHeightExtra := 0; + Canvas.Font := Font; + if GetTextMetrics(Canvas.Handle, TM) then begin + with TM do begin + ChHeight := tmHeight + tmExternalLeading; + ChWidth := (tmMaxCharWidth + tmAveCharWidth) shr 1; + ChRefWidth := tmAveCharWidth; + end; + end; + end; +end; + +procedure TFvcBrowser.SetHighKey(Value: GenKeyStr); +begin + if not CanCallLowBrowser then Exit; + BrowserPtr^.HighKey := Value; + {EraseRowAreaRect;} {!!.53} + SetAndUpdateBrowserScreen((Value), 0); +end; + +procedure TFvcBrowser.SetKeyNr(Value : Word); +begin + if CanCallLowBrowser then begin + BrowserPtr^.KeyNr := Value; + UpdateBrowserScreen; + end; +end; + +procedure TFvcBrowser.SetKeys(KeyNr : Word; Low, High : GenKeyStr); {!!.52} +begin + if not CanCallLowBrowser then Exit; + BrowserPtr^.KeyNr := KeyNr; + BrowserPtr^.LowKey := Low; + BrowserPtr^.HighKey := High; + {EraseRowAreaRect;} {!!.53} + SetAndUpdateBrowserScreen((Low), 0); +end; + +procedure TFvcBrowser.SetLowKey(Value: GenKeyStr); +begin + if not CanCallLowBrowser then Exit; + BrowserPtr^.LowKey := Value; + {EraseRowAreaRect;} {!!.53} + SetAndUpdateBrowserScreen((Value), 0); +end; + +procedure TFvcBrowser.SetMargins; +begin + FillChar(FTextMargin, SizeOf(FTextMargin), 0); +end; + +procedure TFvcBrowser.SetVersion(const Value: string); {!!.56} +begin + { do nothing. Necessary since most versions of Delphi do not support + read only properties. } +end; + +procedure TFvcBrowser.ShowErrorOccured(EClass: Integer); +begin + if EClass > DialogError then {!!.52} + raise Exception.Create(Format('Class %d error. Isam Error %d', + [EClass, IsamError])); +end; + +procedure TFvcBrowser.ShowFilterWorking ( CallState : Integer; + Rejected : Boolean ); +begin + if Assigned(FOnShowFilterWorking) then + FOnShowFilterWorking(Self, CallState, Rejected); +end; + +procedure TFvcBrowser.SetBorderStyle(Value: TBorderStyle); +begin + if FBorderStyle <> Value then begin + FBorderStyle := Value; + RecreateWnd; + end; +end; + +procedure TFvcBrowser.SetFooterColor(Value: TColor); +begin + if FFooterColor <> Value then begin + FFooterColor := Value; + InvalidateBrowserScreen; {!!.53} + end; +end; + +procedure TFvcBrowser.SetFooter(Value: BRLRowEltString); +begin + if FFooter <> Value then begin + FFooter := Value; + FNoPaintHFCg := False; {!!.52} + InvalidateRect(Handle, nil, True); {!!.52} + if Assigned(BrowserPtr) then ReInit; {!!.52} + UpdateBrowserScreen; + end; +end; + +procedure TFvcBrowser.SetFooterTxtColor(Value: TColor); +begin + if FFooterTxtColor <> Value then begin + FFooterTxtColor := Value; + InvalidateBrowserScreen; {!!.53} + end; +end; + +procedure TFvcBrowser.SetHeaderColor(Value: TColor); +begin + if FHeaderColor <> Value then begin + FHeaderColor := Value; + InvalidateBrowserScreen; {!!.53} + end; +end; + +procedure TFvcBrowser.SetHeader(Value: BRLRowEltString); +begin + if FHeader <> Value then begin + FHeader := Value; + FNoPaintHFCg := False; {!!.52} + InvalidateRect(Handle, nil, True); {!!.52} + if Assigned(BrowserPtr) then ReInit; {!!.52} + UpdateBrowserScreen; + end; +end; + +procedure TFvcBrowser.SetHeaderTxtColor(Value: TColor); +begin + if FHeaderTxtColor <> Value then begin + FHeaderTxtColor := Value; + InvalidateBrowserScreen; {!!.53} + end; +end; + +procedure TFvcBrowser.SetHighlightColor(Value: TColor); +begin + if FHighlightColor <> Value then begin + FHighlightColor := Value; + InvalidateBrowserScreen; {!!.53} + end; +end; + +procedure TFvcBrowser.SetHighlightTxtColor(Value: TColor); +begin + if FHighlightTxtColor <> Value then begin + FHighlightTxtColor := Value; + InvalidateBrowserScreen; {!!.53} + end; +end; + +procedure TFvcBrowser.SetHorizOfs(Value: integer); +begin + if FHorizOfs <> Value then begin + FHorizOfs := AdjustHorizOfs(Value - FHorizOfs); + UpdateBrowserScreen; + end; +end; + +procedure TFvcBrowser.SetFilterEnabled(Value: Boolean); +begin + if FFilterEnabled <> Value then begin + FFilterEnabled := Value; + if FilterInProgress and not Value then EndFilter; + EraseRowAreaRect; + UpdateBrowserScreen; + end; +end; + +procedure TFvcBrowser.SetUseSeparator(Value: Boolean); +begin + if FUseSeparator <> Value then begin + FUseSeparator := Value; + InvalidateBrowserScreen; {!!.53} + end; +end; + +function TFvcBrowser.TotalCharHeight : Word; +begin + Result := FontDescr.ChHeight + FontDescr.ChHeightExtra; + if Result = 0 then Result := 1; +end; + +function TFvcBrowser.TotalSpaceForLines(Rect: TRect): Word; +begin + Result := Rect.Bottom - Rect.Top; +end; + +procedure TFvcBrowser.UpdateBrowserScreen; +begin + if CanCallLowBrowser then lwUpdateBrowserScreen; +end; + +procedure TFvcBrowser.CMFontChanged(var Message: TMessage); {!!.52} +begin {!!.52} + inherited; {!!.52} + NewSize; {!!.52} +end; {!!.52} + +procedure TFvcBrowser.WMGetDlgCode(var Msg: TWMGetDlgCode); +begin + Msg.Result := DLGC_WANTARROWS or DLGC_WANTCHARS; +end; + +procedure TFvcBrowser.WMHScroll(var Msg: TWMHScroll); +begin + if not CanCallLowBrowser then Exit; + if not FilterInProgress then SetFocus; {!!.53} + if not FDoMouseMove then begin + if GetFocus = Handle then + FDoMouseMove := True; + {Exit;} {!!.52} + end; + case Msg.ScrollCode of + SB_ThumbPosition, {!!.53} + SB_EndScroll : begin + if FThumbHTrack <> $FFFF then begin + MoveToHorizPos(FThumbHTrack); + FThumbHTrack := $FFFF; + end; + end; + SB_ThumbTrack : FThumbHTrack := Msg.Pos; + SB_LineRight : LineRight; + SB_LineLeft : LineLeft; + SB_PageRight : PageRight; + SB_PageLeft : PageLeft; + SB_Left : LeftHome; + SB_Right : RightHome; + end; +end; + +procedure TFvcBrowser.WMKillFocus(var Msg: TWMKillFocus); +begin + FDoMouseMove := False; + FNoPaintHFCg := False; + inherited; +end; + +{$IFDEF Delphi4Plus} {!!.57} +procedure TFvcBrowser.CMMouseWheel(var Msg: TCMMouseWheel); {!!.57} +begin {!!.57} + if not CanCallLowBrowser then Exit; {!!.57} + if not FilterInProgress then SetFocus; {!!.57} + if not FDoMouseMove then begin {!!.57} + if GetFocus = Handle then FDoMouseMove := True; {!!.57} + end; {!!.57} + if Msg.WheelDelta > 0 then {!!.57} + LineUp {!!.57} + else {!!.57} + LineDown; {!!.57} +end; {!!.57} +{$ENDIF} {!!.57} + +procedure TFvcBrowser.WMNCMouseMove(var Msg : TWMNCMouseMove); +begin + if not FDoMouseMove then begin + if GetFocus = Handle then FDoMouseMove := True; + end; + inherited; +end; + +procedure TFvcBrowser.WMSize(var Msg: TWMSize); +begin + if CanCallLowBrowser then + if Msg.SizeType <> SizeIconic then + NewSize; + inherited; +end; + +procedure TFvcBrowser.WMVScroll(var Msg: TWMVScroll); +begin + if not CanCallLowBrowser then Exit; + if not FilterInProgress then SetFocus; {!!.53} + if not FDoMouseMove then begin + if GetFocus = Handle then FDoMouseMove := True; + {Exit;} {!!.52} + end; + case Msg.ScrollCode of + SB_ThumbPosition, {!!.53} + SB_EndScroll : begin + if FThumbVTrack <> $FFFF then begin + MoveToRelPos(FThumbVTrack); + FThumbVTrack := $FFFF; + end; + end; + SB_LineDown : LineDown; + SB_LineUp : LineUp; + SB_PageDown : PageDown; + SB_PageUp : PageUp; + SB_ThumbTrack : FThumbVTrack := Msg.Pos; + SB_Top : FirstPage; + SB_Bottom : LastPage; + end; +end; + +procedure TFvcBrowser.WriteDataLine(var DataLine : BRLRowEltString; + LineNr : Word); +begin + WriteStringOut(DataLine, LineNr, -FHorizOfs); +end; + +procedure TFvcBrowser.WriteFooter; +var + SepPos : Word; +begin + SepPos := WriteStringOut(FFooter, Succ(FullPage), -FHorizOfs); {!!.53} + if FUseSeparator then DrawSeparator(SepPos - 1); +end; + +procedure TFvcBrowser.WriteHeader; +var + SepPos: Word; +begin + SepPos := WriteStringOut(FHeader, 0, -FHorizOfs); + if FUseSeparator then DrawSeparator(SepPos + FontDescr.ChHeight - 1); +end; + +function TFvcBrowser.WriteStringOut(var S: BRLRowEltString; LineNr: word; XOfs: integer): word; +begin + Result := GetTextOutPosY(LineNr); + Canvas.TextOut(XOfs + FTextMargin.Left, Result, S); +end; + +function TFvcBrowser.XYPosInRect(X, Y: Integer; Rect: TRect): Boolean; +begin + Result := (X >= Rect.Left) and (X < Rect.Right) + and (Y >= Rect.Top) and (Y < Rect.Bottom); +end; + +procedure TFvcBrowser.Paint; +var + I, + CR : Word; +begin + Canvas.Font := Font; + if Assigned(BrowserPtr) then begin + CR := BrowserPtr^.GetCurRow; + for I := 1 to FullPage do begin + DisplayRow (I, I = CR); + end; + end; +end; + +procedure TFvcBrowser.FileblockHasClosed; {!!.54} +begin + FBIsClosed := true; +end; + +end. diff --git a/src/wc_sdk/fvcreg.pas b/src/wc_sdk/fvcreg.pas new file mode 100644 index 0000000..5021c2e --- /dev/null +++ b/src/wc_sdk/fvcreg.pas @@ -0,0 +1,51 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{ Registration unit for the FVCBrowser component } + +{$IFDEF Win32} + {$R FVCBROWS.R32} +{$ELSE} + {$R FVCBROWS.R16} +{$ENDIF} + +unit FvcReg; + +interface + +uses Classes, FvcBrows; + +procedure Register; + +implementation + +procedure Register; +begin + RegisterComponents('B-Tree Filer', [TFvcBrowser]); +end; + +end. diff --git a/src/wc_sdk/hibrows.pas b/src/wc_sdk/hibrows.pas new file mode 100644 index 0000000..e48493f --- /dev/null +++ b/src/wc_sdk/hibrows.pas @@ -0,0 +1,523 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I brdefopt.inc} + {$F-,V-,B-,S-,I-,R-} + {$IFDEF CanAllowOverlays} + {$O+,F+} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-} + {$ENDIF} + + +Unit HiBrows; + +Interface + +Uses + LowBrows, + MedBrows; + +Type + PBRHBrowser = ^BRHBrowser; + BRHBrowser = Object ( BRMBrowser ) + OtherAction, + StatusOK : Boolean; + + Constructor Init ( DrvOrFileBlockPtr : Pointer; + NumberOfEltsPerRow : Word; + NumberOfRows : Word; + LKey, + HKey : GenKeyStr; + SaveStat : Boolean; + Var DatS; + IsVarRec : Boolean ); + Destructor Done; virtual; + Procedure SetDefaults; + + {--The following routines may be overwritten in descending objects} + Procedure ShowErrorOccured ( EClass : Integer ); Virtual; {!!.51} + + {--The following routines must not be overwritten in descending objects} + Procedure HBuildFirstPage ( Var Changed : Boolean ); + Procedure HBuildLastPage ( Var Changed : Boolean ); + Procedure HBuildNextPage ( Nr : Word; + Var Moved : Word; + CompletePage : Boolean; + ModifyCurRow : Word; + Var Changed : Boolean ); + Procedure HBuildPrevPage ( Nr : Word; + Var Moved : Word; + CompletePage : Boolean; + ModifyCurRow : Word; + Var Changed : Boolean ); + Procedure HBuildThisPage ( Var Changed : Boolean ); + Procedure HExpandPage ( NewNrOfRows : Word ); + Procedure HShrinkPage ( NewNrOfRows : Word ); + Procedure HBuildNewPage ( NewKeyNr : Word; + NewKeyStr : GenKeyStr; + NewRef : LongInt; + NewCurRow : Word; + NewNrOfRows : Word ); + Procedure HGetApprKeyAndRef ( RelPos : Word; + Scale : Word; + Var UserKey : GenKeyStr; + Var UserDatRef : LongInt ); + Procedure HGetApprRelPos ( Var RelPos : Word; + Scale : Word; + UserKey : GenKeyStr; + UserDatRef : LongInt ); + + {--The following routines are internal use only} + Procedure PrivatSetDefaults; + Procedure ErrorInspect ( Result : Integer ); + End; + + +Implementation + +Const + DefDelayOnGetRec = 6; + DefRetrOnGetRec = 6; + DefNrOfRowsConst = 20; + + Constructor BRHBrowser.Init ( DrvOrFileBlockPtr : Pointer; + NumberOfEltsPerRow : Word; + NumberOfRows : Word; + LKey, + HKey : GenKeyStr; + SaveStat : Boolean; + Var DatS; + IsVarRec : Boolean ); + + Begin + If Not BRMBrowser.Init ( DrvOrFileBlockPtr, NumberOfEltsPerRow, + NumberOfRows, DefDelayOnGetRec, DefRetrOnGetRec, DefNrOfRowsConst, + LKey, HKey, SaveStat, DatS, IsVarRec ) Then Fail; + PrivatSetDefaults; + End; + + + Destructor BRHBrowser.Done; + + Begin + BRMBrowser.Done; + End; + + + Procedure BRHBrowser.SetDefaults; + + Begin + BRMBrowser.SetDefaults; + PrivatSetDefaults; + End; + + + Procedure BRHBrowser.PrivatSetDefaults; + + Begin + StatusOK := False; + OtherAction := False; + End; + + + Procedure BRHBrowser.ShowErrorOccured ( EClass : Integer ); {!!.51} + + Begin + End; + + + Procedure BRHBrowser.ErrorInspect ( Result : Integer ); + + Begin + OtherAction := False; + StatusOK := Result = NoError; + If Not StatusOK Then ShowErrorOccured ( Result ); + End; + + + Procedure BRHBrowser.HBuildFirstPage ( Var Changed : Boolean ); + + Begin + ErrorInspect ( BuildFirstPage ( Changed ) ); + End; + + + Procedure BRHBrowser.HBuildLastPage ( Var Changed : Boolean ); + + Begin + ErrorInspect ( BuildLastPage ( Changed ) ); + End; + + + Procedure BRHBrowser.HBuildNextPage ( Nr : Word; + Var Moved : Word; + CompletePage : Boolean; + ModifyCurRow : Word; + Var Changed : Boolean ); + + Var + OAValue : Boolean; + + Begin + If Not StatusOK Then Begin + HBuildThisPage ( Changed ); + OAValue := True; + End Else Begin + OAValue := False; + End; + If StatusOK Then Begin + ErrorInspect ( BuildNextPage ( Nr, Moved, CompletePage, ModifyCurRow, + Changed ) ); + End; + OtherAction := OAValue; + End; + + + Procedure BRHBrowser.HBuildPrevPage ( Nr : Word; + Var Moved : Word; + CompletePage : Boolean; + ModifyCurRow : Word; + Var Changed : Boolean ); + + Var + OAValue : Boolean; + + Begin + If Not StatusOK Then Begin + HBuildThisPage ( Changed ); + OAValue := True; + End Else Begin + OAValue := False; + End; + If StatusOK Then Begin + ErrorInspect ( BuildPrevPage ( Nr, Moved, CompletePage, ModifyCurRow, + Changed ) ); + End; + OtherAction := OAValue; + End; + + + Procedure BRHBrowser.HBuildThisPage ( Var Changed : Boolean ); + + Begin + Changed := True; + If Not StatusOK Then Begin + If (CurRow <= GetLastRow) And (CurRow > 0) Then Begin + ErrorInspect ( BuildThisPage ( Changed ) ); + End Else Begin + HBuildFirstPage ( Changed ); + End; + End Else Begin + ErrorInspect ( BuildThisPage ( Changed ) ); + End; + End; + + + Procedure BRHBrowser.HExpandPage ( NewNrOfRows : Word ); + + Var + Dummy : Boolean; + + Begin + If Not StatusOK Then Begin + If NewNrOfRows > AllocNrOfRows Then Exit; + NrOfRows := NewNrOfRows; + HBuildThisPage ( Dummy ); + End Else Begin + ErrorInspect ( ExpandPage ( NewNrOfRows ) ); + End; + End; + + + Procedure BRHBrowser.HShrinkPage ( NewNrOfRows : Word ); + + Var + Dummy : Boolean; + + Begin + If Not StatusOK Then Begin + If NewNrOfRows = 0 Then Exit; + NrOfRows := NewNrOfRows; + HBuildThisPage ( Dummy ); + End Else Begin + ErrorInspect ( ShrinkPage ( NewNrOfRows ) ); + End; + End; + + + Procedure BRHBrowser.HBuildNewPage ( NewKeyNr : Word; + NewKeyStr : GenKeyStr; + NewRef : LongInt; + NewCurRow : Word; + NewNrOfRows : Word ); + + Var + Dummy : Boolean; + + Begin + ErrorInspect ( BuildNewPage ( NewKeyNr, NewKeyStr, NewRef, NewCurRow, + NewNrOfRows, Dummy ) ); + End; + + + Procedure BRHBrowser.HGetApprKeyAndRef ( RelPos : Word; + Scale : Word; + Var UserKey : GenKeyStr; + Var UserDatRef : LongInt ); + + Var + TRowRec : RowRec; + Dummy : Integer; + + + Procedure GetMaxPosKeyStr ( Var KeyStr : GenKeyStr ); + + Begin + KeyStr := ''; + While Length (KeyStr) < GenMaxKeyLen Do Begin + KeyStr := KeyStr + #255; + End; + End; + + + Procedure Approximate ( Var FinalKeyStr : GenKeyStr; + Var FinalRef : LongInt ); + + Type + PosPoint = Record + ResKey : GenKeyStr; + ResRef : LongInt; + TestRelPos, + ResRelPos : Word; + End; + + Var + PLow, + PTest, + PHigh : PosPoint; + Stop : Boolean; + + + Procedure NextStep ( TestRelPos : Word; + Var ResKey : GenKeyStr; + Var ResRef : LongInt; + Var ResRelPos : Word ); + + Begin + ErrorInspect ( BRLGetApprKeyAndRef ( TestRelPos, Scale, ResKey, + ResRef ) ); + If Not StatusOK Then Exit; + HGetApprRelPos ( ResRelPos, Scale, ResKey, ResRef ); + End; + + + Procedure SetPTestToMin; + + Var + AbsDiff, + BestAbsDiff : Word; + + Begin + BestAbsDiff := Abs (LongInt (PTest.ResRelPos) - LongInt (RelPos)); + AbsDiff := Abs (LongInt (PLow.ResRelPos) - LongInt (RelPos)); + If AbsDiff < BestAbsDiff Then Begin + BestAbsDiff := AbsDiff; + PTest := PLow; + End; + AbsDiff := Abs (LongInt (PHigh.ResRelPos) - LongInt (RelPos)); + If AbsDiff < BestAbsDiff Then Begin + PTest := PHigh; + End; + End; + + + Begin + PTest.TestRelPos := Scale Div 2; + With PLow Do Begin + ResKey := ''; + ResRef := 0; + TestRelPos := 0; + ResRelPos := 0; + End; + With PHigh Do Begin + GetMaxPosKeyStr ( ResKey ); + ResRef := GenMaxPosRef; + TestRelPos := Scale; + ResRelPos := Scale; + End; + + Stop := False; + Repeat + With PTest Do Begin + NextStep ( TestRelPos, ResKey, ResRef, ResRelPos ); + End; + If Not StatusOK Then Exit; + If PTest.ResRelPos <> RelPos Then Begin + If PTest.ResRelPos > RelPos Then Begin + PHigh := PTest; + End Else Begin + PLow := PTest; + End; + If ((PLow.ResKey = PHigh.ResKey) And (PLow.ResRef = PHigh.ResRef)) + Or (PLow.ResRelPos = PHigh.ResRelPos) Then Begin + Stop := True; + End Else Begin + PTest.TestRelPos := (PLow.TestRelPos + PHigh.TestRelPos) Div 2; + If (PTest.TestRelPos = PLow.TestRelPos) + Or (PTest.TestRelPos = PHigh.TestRelPos) Then Begin + Stop := True; + SetPTestToMin; + End; + End; + End Else Begin + Stop := True; + End; + Until Stop; + + With PTest Do Begin + FinalKeyStr := ResKey; + FinalRef := ResRef; + End; + End; + + + Begin + With TRowRec Do Begin + If RelPos = 0 Then Begin + IKS := ''; + Ref := 0; + ErrorInspect ( BRFindKeyAndRefNoFilter ( TRowRec, 1 ) ); {!!.04} + If StatusOK Then Begin + UserKey := IKS; + UserDatRef := Ref; + End; + Exit; + End Else Begin + If RelPos >= Scale Then Begin + GetMaxPosKeyStr ( IKS ); + Ref := GenMaxPosRef; + ErrorInspect ( BRFindKeyAndRefNoFilter ( TRowRec, -1 ) ); {!!.04} + If StatusOK Then Begin + UserKey := IKS; + UserDatRef := Ref; + End; + Exit; + End; + End; + End; + UserKey := ''; + UserDatRef := 0; + ErrorInspect ( BRLDoReadLock ); + If Not StatusOK Then Exit; + Approximate ( UserKey, UserDatRef ); + If StatusOK Then Begin + ErrorInspect ( BRLDoUnLock ); + End Else Begin + Dummy := BRLDoUnLock; + End; + End; + + + Procedure BRHBrowser.HGetApprRelPos ( Var RelPos : Word; + Scale : Word; + UserKey : GenKeyStr; + UserDatRef : LongInt ); + + Var + ScaleAdd : Word; + NewScale : Word; + SubLow : Word; + UsedKeys : LongInt; + + Begin + RelPos := 0; + ErrorInspect ( BRLDoReadLock ); + If Not StatusOK Then Exit; + ErrorInspect ( BRLUsedKeys ( UsedKeys ) ); + If Not StatusOK Then Begin + ErrorInspect ( BRLDoUnLock ); + Exit; + End; + Case UsedKeys Of + 0, 1 :; + Else Begin + Case Scale Div UsedKeys Of + 0 : Begin + ScaleAdd := 2; + End; + 1 : Begin + ScaleAdd := Scale Div (Scale Div 4); + End; + 2 : Begin + ScaleAdd := Scale Div (Scale Div 8); + End; + 3, 4 : Begin + ScaleAdd := Scale Div (Scale Div 10); + End; + 5..10 : Begin + ScaleAdd := Scale Div (Scale Div 25); + End; + 11..20 : Begin + ScaleAdd := Scale Div (Scale Div 50); + End; + 21..25 : Begin + ScaleAdd := Scale; + End; + 26..33 : Begin + ScaleAdd := Scale * 2; + End; + Else Begin + ScaleAdd := Scale * 4; + End; + End; {Case} + If ScaleAdd < 2 Then ScaleAdd := 2; + ScaleAdd := ScaleAdd And $FFFE; + NewScale := Scale + ScaleAdd; + ErrorInspect ( BRLGetApprRelPos ( RelPos, NewScale, UserKey, + UserDatRef ) ); + If StatusOK Then Begin + SubLow := ScaleAdd Div 2; + If RelPos <= SubLow Then Begin + RelPos := 0; + End Else Begin + Dec ( RelPos, SubLow ); + If RelPos > Scale Then RelPos := Scale; + End; + End; + End; + End; {Case} + ErrorInspect ( BRLDoUnLock ); + End; + + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/isambase.inc b/src/wc_sdk/isambase.inc new file mode 100644 index 0000000..66141e6 --- /dev/null +++ b/src/wc_sdk/isambase.inc @@ -0,0 +1,371 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +function IsamCheckLockError : Boolean; +begin + IsamCheckLockError := False; + if IsamDriveNotReadyError or (IOResult = 152) then begin + IsamDriveNotReadyError := False; + IsamLockError := False; + IsamOK := False; + IsamError := 10110; + IsamCheckLockError := True; + Exit; + end; + if IsamLockError then begin + IsamLockError := False; + IsamOK := False; + IsamError := 10140; + IsamCheckLockError := True; + end; +end; + + +procedure IsamClearOK; +begin + IsamOK := True; + IsamError := 0; + IsamLockError := False; + IsamDriveNotReadyError := False; + IsamDOSError := 0; + IsamDOSFunc := 0; +end; + + +procedure SaveErrorStat(var ErrSt : ErrStatSaveRec); +begin + with ErrSt do begin + OK := IsamOK; + Error := IsamError; + DError := IsamDOSError; + DFunc := IsamDOSFunc; + end; +end; + + +procedure RestoreErrorStat(ErrSt : ErrStatSaveRec); +begin + with ErrSt do begin + IsamOK := OK; + IsamError := Error; + IsamDOSError := DError; + IsamDOSFunc := DFunc; + end; +end; + + +function IsamSetDosRetry(NrOfRetries, WaitTime : Integer) : Boolean; +{$IFDEF Win32} + begin + {do nothing} + Result := true; + end; +{$ELSE} +var + IRR : GenRegisters; +begin + DefaultRegisters(IRR); + with IRR do begin + AX := $440B; + BX := NrOfRetries; + CX := WaitTime; + DX := NrOfRetries; + if IsamDOSError = 0 then + IsamDOSFunc := AX; + CallMsDos(IRR); + if odd(Flags) and (IsamDOSError = 0) then + IsamDOSError := AX; + IsamSetDosRetry := not odd(Flags); + end; +end; +{$ENDIF} + + +function IsamGetFileName(var F : IsamFile) : IsamFileName; +var + FName : IsamFileName; +begin + FName [0] := Char (Pred (SizeOf (IsamFileName))); + Move(F.Name, FName [1], Byte (FName [0])); + FName [0] := Char (Pred (Pos (#0, FName))); + IsamGetFileName := FName; +end; + + +function IsamExistsIsamFile(var IsamF : IsamFile) : Boolean; +{$IFDEF Win32} +var + FA : DWORD; {!!.54} +begin + if (IsamDOSError = 0) then + IsamDOSFunc := $4300; + FA := Windows.GetFileAttributes(IsamF.Name); + if (FA = $FFFFFFFF) then begin + Result := false; + if (IsamDOSError = 0) then + IsamDOSError := GetLastError; + end + else + Result := true; +end; +{$ELSE} +var + IRR : GenRegisters; +begin + DefaultRegisters(IRR); + with IRR, IsamF do begin + AX := $4300; {get file attribute} + DS := Seg (Name); + DX := Ofs (Name); + if IsamDOSError = 0 then + IsamDOSFunc := AX; + CallMsDos(IRR); + IsamExistsIsamFile := False; + if IsamCheckLockError then + Exit; + if odd(Flags) and (IsamDOSError = 0) then + IsamDOSError := AX; + IsamExistsIsamFile := not odd(Flags); + end; +end; +{$ENDIF} + + +function IsamExists(Name : IsamFileName) : Boolean; +var + IsamF : IsamFile; +begin + IsamAssign(IsamF, Name); + IsamExists := IsamExistsIsamFile(IsamF); +end; + + +procedure IsamPutDummyBlock(var F : IsamFile; Ref, Len : LongInt); + {!!.52 rewritten} +const + EmptyArrLen = 1024; +var + EmptyArr : Array [1..EmptyArrLen] of Char; + BufPtr : Pointer; + GotMem : boolean; +begin + {$IFDEF Win32} + if (Len > EmptyArrLen) then + {$ELSE} + if (Len > EmptyArrLen) and (Len < $FFF0) then + {$ENDIF} + GotMem := IsamGetMem(BufPtr, Len) + else + GotMem := false; + if GotMem then begin + FillChar(BufPtr^, Len, 0); + IsamPutBlock(F, Ref, Len, BufPtr^); + FreeMem(BufPtr, Len); + end + else begin + FillChar(EmptyArr, sizeof(EmptyArr), 0); + IsamLongSeek(F, Ref); + if not IsamOK then + Exit; + while (Len > EmptyArrLen) do begin + IsamBlockWrite(F, EmptyArr, sizeof(EmptyArr)); + if not IsamOK then + Exit; + Len := Len - sizeof(EmptyArr); + end; + IsamBlockWrite(F, EmptyArr, Word(Len)); + end; +end; + + +procedure IsamExtractFileNames( FNameComp : IsamFileBlockName; + var FNameD, + FNameI : IsamFileBlockName); +var + SP : Word; + {------} + procedure Trim(var S : IsamFileBlockName); + var + P : Word; + begin + while True do begin + P := Pos(' ', S); + if P = 0 then + Exit; + Delete(S, P, 1); + end; + end; + {------} +begin + {Trim(FNameComp);} {!!.53} + SP := Pos(';', FNameComp); + if SP = 0 then begin + FNameD := FNameComp; + FNameI := FNameComp; + end + else begin + FNameD := Copy(FNameComp, 1, Pred (SP)); + FNameI := Copy(FNameComp, Succ (SP), Length (FNameComp) - SP); + end; +end; + + +procedure IsamCopyFile(Source, + Dest : IsamFileBlockName; + DeleteSourceAfterCopy : Boolean); + {!!.52 rewritten} +{$IFDEF Win32} +var + SourceZ : array [0..MAX_PATH] of char; + DestZ : array [0..MAX_PATH] of char; + SourceF : IsamFile; +begin + StrPCopy(SourceZ, Source); + StrPCopy(DestZ, Dest); + if not Windows.CopyFile(SourceZ, DestZ, True) then begin + IsamOK := false; + IsamError := 10075; + Exit; + end; + if DeleteSourceAfterCopy then begin + IsamAssign(SourceF, Source); + IsamDelete(SourceF); + end; +end; +{$ELSE} +var + SourceF, + DestF : IsamFile; + BufPtr : Pointer; + BufSize, + BytesRead : Longint; + {----} + procedure UnDo(Err : Integer; Level : integer); + begin + if Level >= 3 then + FreeMem(BufPtr, BufSize); + if Level >= 2 then + IsamClose(DestF); + if Level >= 1 then + IsamClose(SourceF); + IsamOK := False; + IsamError := Err; + end; + {----} + procedure GetCopyBuffer(var BufPtr : pointer; var Size : longint); + const + MinBufSize = 1024; + MaxBufSize = 32768; + begin + Size := MaxBufSize; + repeat + if IsamGetMem(BufPtr, Size) then + Exit; + dec(Size, MinBufSize); + until (Size < MinBufSize); + end; + {----} +begin + IsamAssign(SourceF, Source); + IsamAssign(DestF, Dest); + IsamReset(SourceF, False, True); + if not IsamOK then + Exit; + IsamRewrite(DestF); + if not IsamOK then begin + UnDo(IsamError, 1); + Exit; + end; + GetCopyBuffer(BufPtr, BufSize); + if (BufPtr = nil) then begin + UnDo(10420, 2); + Exit; + end; + repeat + IsamBlockReadRetLen(SourceF, BufPtr^, BufSize, BytesRead); + if not IsamOK then begin + UnDo(IsamError, 3); + Exit; + end; + if (BytesRead <> 0) then begin + IsamBlockWrite(DestF, BufPtr^, BytesRead); + if not IsamOK then begin + UnDo(IsamError, 3); + Exit; + end; + end; + until (BytesRead = 0); + FreeMem(BufPtr, BufSize); + IsamClose(DestF); + if not IsamOK then begin + UnDo(IsamError, 1); + Exit; + end; + IsamClose(SourceF); + if DeleteSourceAfterCopy then IsamDelete(SourceF); +end; +{$ENDIF} + + +function IsamForceExtension(Name, Ext : IsamFileName) : IsamFileName; +var + DotPos : Word; + {------} + function HasExtension(Name : IsamFileBlockName; var DotPos : Word) + : Boolean; + var + W : Word; + begin + DotPos := 0; + For W := Length (Name) DownTo 1 do begin + if (Name [W] = '.') and (DotPos = 0) then begin + DotPos := W; + end; + end; + HasExtension := (DotPos > 0) and + (Pos ('\', Copy (Name, Succ (DotPos), 255)) = 0); + end; + {------} +begin + if HasExtension(Name, DotPos) then begin + IsamForceExtension := Copy(Name, 1, DotPos) + Ext; + end + else begin + IsamForceExtension := Name + '.' + Ext; + end; +end; + + +{$IFDEF Heap6} +function RoundToGranul(Value : Word) : Word; + {-Rounds Value up to the next multiple of 8} +begin + RoundToGranul := (Value + 7) and $FFF8; +end; +{$ENDIF} + + diff --git a/src/wc_sdk/isamlow.inc b/src/wc_sdk/isamlow.inc new file mode 100644 index 0000000..6db9f0c --- /dev/null +++ b/src/wc_sdk/isamlow.inc @@ -0,0 +1,2121 @@ +{********************************************************************} +{* ISAMLOW.INC *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +procedure ISInitIsam; +begin + IsamClearOK; + IsamIsCriticalActive := False; + IsamOFBLPtr := Nil; + IsamForceFlushOfMark := False; + {$IFNDEF VER60} {!!.53} + {$IFNDEF VER15} {!!.53} + IsamReXUserProcPtr := Nil; {!!.53} + {$else} {!!.53} + FillChar(IsamReXUserProcPtr, sizeof(IsamReXUserProcPtr), 0); {!!.53} + {$ENDIF} {!!.53} + {$else} {!!.53} + FillChar(IsamReXUserProcPtr, sizeof(IsamReXUserProcPtr), 0); {!!.53} + {$ENDIF} {!!.53} + UserSaveEMSHandle := 0; + {$IFNDEF Win32} + if Swap(CallDosVersion) < $031E then + IsamFlushDOS33 := False; + {-Set IsamFlushDOS33 to False if not DOS Version 3.3 or higher} + {$ENDIF} +end; + + +procedure IsamAddRec( IFBPtr : IsamFileBlockPtr; + var RefNr : LongInt; + var Source); + {------} + procedure AddRec1; + var + IR : IsamInfoRec; + OldFirstFree : LongInt; + begin + IsamSetDataBufferedFlag(IFBPtr); + if not IsamOK then Exit; + with IFBPtr^ do begin + if SaveFB then + IsamCopyInfoRecToIR(IFBPtr, 0, IR); + with DIDPtr^[0]^ do begin + OldFirstFree := FirstFree; + IsamNewRec(IFBPtr, RefNr, 0); + if not IsamOK then Exit; + if SaveFB then begin + if IsamFirstFreeChanged(IFBPtr, 0) then begin + IsamSaveGivenInfoRec(IFBPtr, 0, IR, FirstFree); + end + else begin + IsamSaveGivenInfoRec(IFBPtr, 0, IR, -2); + if not IsamOK then + Dec(NumRec); + end; + if not IsamOK then Exit; + if (NSP = Nil) or IsamNetEmu then + IsamFlushDOSDia(IFBPtr, False); + end; + IsamPutBlock(DatF, RefNr * LenRec, LenRec, Source); + if not IsamOK then begin + if IsamFirstFreeChanged(IFBPtr, 0) then begin + FirstFree := OldFirstFree; + Inc(NumberFree); + end + else begin + Dec(NumRec); + end; + Exit; + end; + end; + if SaveFB then begin + if (NSP = Nil) or IsamNetEmu then begin + IsamFlushDOSDat(IFBPtr); + end + else begin + IsamPutInfoRec(IFBPtr, 0, False); + end; + end; + end; + end; + {------} +begin + IsamClearOK; + AddRec1; + if IFBPtr^.SaveFB then begin + if IsamOK then begin + IsamReduceDiaFile(IFBPtr); + end + else begin + IsamRepairFileBlock(IFBPtr); + if IsamOK then begin + IsamOK := False; + IsamError := 10001; + end; + end; + end; +end; + + +procedure IsamDeleteRec(IFBPtr : IsamFileBlockPtr; RefNr : LongInt); + {------} + procedure DeleteRec1; + var + IR : IsamInfoRec; + begin + IsamSetDataBufferedFlag(IFBPtr); + if not IsamOK then Exit; + with IFBPtr^ do begin + if SaveFB then begin + IsamCopyInfoRecToIR(IFBPtr, 0, IR); + if IsamFirstFreeChanged(IFBPtr, 0) then begin + IsamSaveGivenInfoRec(IFBPtr, 0, IR, DIDPtr^[0]^.FirstFree); + end + else begin + IsamSaveGivenInfoRec(IFBPtr, 0, IR, -2); + end; + if not IsamOK then Exit; + if (NSP = Nil) or IsamNetEmu then + IsamFlushDOSDia(IFBPtr, False); + end; + IsamDeleteRecOrPage(IFBPtr, RefNr, 0); + if not IsamOK then Exit; + if SaveFB then begin + if (NSP = Nil) or IsamNetEmu then begin + IsamFlushDOSDat(IFBPtr); + end + else begin + IsamPutInfoRec(IFBPtr, 0, False); + end; + end; + end; + end; + {------} +begin + IsamClearOK; + if (RefNr <= 0) or (RefNr > IFBPtr^.DIDPtr^[0]^.NumRec) then begin + IsamOK := False; + IsamError := 10135; + Exit; + end; + DeleteRec1; + if IFBPtr^.SaveFB then begin + if IsamOK then begin + IsamReduceDiaFile(IFBPtr); + end + else begin + IsamRepairFileBlock(IFBPtr); + if IsamOK then begin + IsamOK := False; + IsamError := 10002; + end; + end; + end; +end; + + +procedure IsamPutRec(IFBPtr : IsamFileBlockPtr; {!!.50} + RefNr : LongInt; + var Source); +begin + if RefNr <> 0 then begin + with IFBPtr^, DIDPtr^[0]^ do begin + IsamPutBlock(DatF, RefNr * LenRec, LenRec, Source); + if IsamOK then begin + if SaveFB and((NSP = Nil) or IsamNetEmu) then begin + IsamOnlyFlushDOSDat(IFBPtr); + end; + end; + end; + end + else begin + IsamOK := False; + IsamError := 10130; + end; +end; + + +procedure IsamGetRec(IFBPtr : IsamFileBlockPtr; {!!.50} + RefNr : LongInt; + var Dest); + +var {!!.53} + RefPtr : LongPtr; {!!.53} + Dummy1Ptr, {!!.53} + Dummy2Ptr : IsamLockEntryRecPtr; {!!.53} + IsToUnLock : Boolean; {!!.53} +begin + {$IFDEF LockBeforeRead} + IsToUnLock := False; + with IFBPtr^, DIDPtr^[0]^ do begin + if IsamOK and(NSP <> Nil) then begin + IsamIsInLockList(@IFBPtr^.NSP^.LockEntryRec, RefNr, RefPtr, + False, Dummy1Ptr, Dummy2Ptr); {!!.42} + IsToUnLock := RefPtr = Nil; + if IsToUnLock then begin + IsamOK := btfLockMgrAcqLock(DatF.Handle, + RefNr * LenRec, SizeOf(LongInt), + 0, 0); + if not IsamOK then + IsamError := 10140; + IsToUnLock := IsamOK; + end; + end; + end; + {$ENDIF} + if IsamOK then begin + with IFBPtr^, DIDPtr^[0]^ do begin + IsamGetBlock(DatF, RefNr * LenRec, LenRec, Dest); + end; + end; + {$IFDEF LockBeforeRead} + if IsToUnLock then begin + with IFBPtr^, DIDPtr^[0]^ do begin + if not btfLockMgrRelLock(DatF.Handle, RefNr * LenRec, SizeOf(LongInt)) then begin + IsamOK := False; + IsamError := 10341; + end; + end; + end; + {$ENDIF} +end; + + +procedure IsamGetRecReadOnly(IFBPtr : IsamFileBlockPtr; {!!.50} + RefNr : LongInt; + var Dest ); +var + {$IFDEF VER60} + TPtr : pointer; + {$else} + TPtr : PChar; {!!.52} + {$ENDIF} + RefPtr : LongPtr; {!!.53} + Dummy1Ptr, {!!.53} + Dummy2Ptr : IsamLockEntryRecPtr; {!!.53} + IsToUnLock : Boolean; {!!.53} + +begin + {$IFDEF LockBeforeRead} + IsToUnLock := False; + with IFBPtr^, DIDPtr^[0]^ do begin + if IsamOK and(NSP <> Nil) then begin + IsamIsInLockList(@IFBPtr^.NSP^.LockEntryRec, RefNr, RefPtr, + False, Dummy1Ptr, Dummy2Ptr); {!!.42} + IsToUnLock := RefPtr = Nil; + if IsToUnLock then begin + IsamOK := btfLockMgrAcqLock(DatF.Handle, + RefNr * LenRec, SizeOf(LongInt), + 0, 0); + end; + if IsamOK then begin + IsamGetBlock(DatF, RefNr * LenRec, LenRec, Dest); + end + else begin + IsamClearOK; + {$IFDEF VER60} + TPtr := Ptr(Seg(Dest), Ofs(Dest) + sizeof(longint)); + {$else} + TPtr := @Dest; {!!.52} + inc(TPtr, 4); {!!.52} + {$ENDIF} + IsamGetBlock(DatF, RefNr * LenRec + SizeOf(LongInt), + LenRec - SizeOf(LongInt), TPtr^); + if IsamOK then begin + IsamOK := False; + IsamError := 10205; + end; + end; + if IsToUnLock then begin + if not btfLockMgrRelLock(DatF.Handle, RefNr * LenRec, SizeOf(LongInt)) then begin + end; + end; + end + else begin + if IsamOK then begin + IsamGetBlock(DatF, RefNr * LenRec, LenRec, Dest); + end; + end; + end; + {$else} + if IsamOK then begin + with IFBPtr^, DIDPtr^[0]^ do begin + IsamGetBlock(DatF, RefNr * LenRec, LenRec, Dest); + if (IsamError = 10140) or (IsamError = 10335) then begin {!!.54} + IsamClearOK; + {$IFDEF VER60} + TPtr := Ptr(Seg(Dest), Ofs(Dest) + sizeof(longint)); + {$else} + TPtr := @Dest; {!!.52} + inc(TPtr, 4); {!!.52} + {$ENDIF} + IsamGetBlock(DatF, RefNr * LenRec + SizeOf(LongInt), + LenRec - SizeOf(LongInt), TPtr^); + if IsamOK then begin + IsamOK := False; + IsamError := 10205; + end; + end; + end; + end; + {$ENDIF} +end; + + +procedure IsamReleasePageBuffer; +var + T1Ptr, + T2Ptr, + T3Ptr : IsamRingBufferRecPtr; +begin + if IsamRBR1Ptr = Nil then Exit; + T1Ptr := IsamRBR1Ptr^.Next; + repeat + T2Ptr := T1Ptr; + T3Ptr := T1Ptr; + T1Ptr := T1Ptr^.Next; + with T3Ptr^ do begin + {$IFDEF UseEMSHeap} + if EMSEntry then begin + FreeEMSMem(EMSPointer(PageEntryPtr), SizeOf(IsamPageEntry)); + end + else begin + {$ENDIF} + FreeMem(PageEntryPtr, SizeOf(IsamPageEntry)); + {$IFDEF UseEMSHeap} + end; + {$ENDIF} + IFBlPtr := Nil; + UpDated := False; + end; + FreeMem(T3Ptr, SizeOf(IsamRingBufferRec)); + until T2Ptr = IsamRBR1Ptr; + IsamRBR1Ptr := Nil; +end; + +{$IFDEF UseWindowsInit} +function IsamGetPageBuffer(Pages : integer) : integer; {!!.52 rewritten} + {------} + procedure InitAndInsertInRing(var RBRPtr : IsamRingBufferRecPtr; + PEPtr : IsamPageEntryPtr); + begin + if not IsamGetMem(RBRPtr, sizeof(IsamRingBufferRec)) then + Exit; + inc(IsamNrOfRingBufferRecs); + with RBRPtr^ do begin + IFBlPtr := nil; + EMSEntry := False; + UpDated := False; + SaveBuffered := False; + PageEntryPtr := PEPtr; + end; + if (IsamNrOfRingBufferRecs = 1) then begin + IsamRBR1Ptr := RBRPtr; + with IsamRBR1Ptr^ do begin + Prev := IsamRBR1Ptr; + Next := IsamRBR1Ptr; + end; + end + else begin + RBRPtr^.Prev := IsamRBR1Ptr; + with IsamRBR1Ptr^ do begin + RBRPtr^.Next := Next; + Next^.Prev := RBRPtr; + Next := RBRPtr; + end; + end; + end; + {------} + procedure GetPageBuffer(MaxNrOfRecs : integer); + var + T1Ptr : IsamPageEntryPtr; + T2Ptr : IsamRingBufferRecPtr; + begin + while (Pages > IsamNrOfRingBufferRecs) and + (IsamNrOfRingBufferRecs < MaxNrOfRecs) do begin + if not IsamGetMem(T1Ptr, sizeof(IsamPageEntry)) then + Exit; + InitAndInsertInRing(T2Ptr, T1Ptr); + if (T2Ptr = nil) then begin + FreeMem(T1Ptr, sizeof(IsamPageEntry)); + Exit; + end; + FillChar(T1Ptr^, sizeof(IsamPageEntry), 0); + T1Ptr^.RingBufferPtr := T2Ptr; + end; + end; + {------} +begin + IsamGetPageBuffer := 0; + IsamNrOfRingBufferRecs := 0; + IsamRBR1Ptr := nil; + GetPageBuffer(MaxInt); + if (IsamNrOfRingBufferRecs < MaxHeight) then begin + IsamReleasePageBuffer; + IsamOK := False; + IsamError := 10000; + end + else + IsamGetPageBuffer := IsamNrOfRingBufferRecs; +end; +{$else} +function IsamGetPageBuffer(Free : LongInt; + NrOfEMSTreePages : Word) : LongInt; +var + SaveEMSHeapErrorFuncPtr : Pointer; + UseMinimumNormalHeap : Boolean; + MaxNrOfNormalHeapRecs : Word; + LResult : LongInt; {!!.51} + {------} + procedure InitAndInsertInRing(var RBRPtr : IsamRingBufferRecPtr; + IsEMSEntry : Boolean; + PEPtr : IsamPageEntryPtr); + begin + GetMem(RBRPtr, SizeOf(IsamRingBufferRec)); + Inc(IsamNrOfRingBufferRecs); + with RBRPtr^ do begin + IFBlPtr := Nil; + EMSEntry := IsEMSEntry; + UpDated := False; + SaveBuffered := False; + PageEntryPtr := PEPtr; + end; + if IsamNrOfRingBufferRecs = 1 then begin + IsamRBR1Ptr := RBRPtr; + with IsamRBR1Ptr^ do begin + Prev := IsamRBR1Ptr; + Next := IsamRBR1Ptr; + end; + end + else begin + RBRPtr^.Prev := IsamRBR1Ptr; + with IsamRBR1Ptr^ do begin + RBRPtr^.Next := Next; + Next^.Prev := RBRPtr; + Next := RBRPtr; + end; + end; + end; + {------} + {$IFDEF UseEMSHeap} + procedure GetEMSPageBuffer; + var + T1Ptr : EMSPointer; + T2Ptr : IsamRingBufferRecPtr; + T3Ptr : IsamPageEntryPtr; + begin + while(MemAvail >(LongInt(RoundToGranul(SizeOf(IsamRingBufferRec))) + + Free)) + and IsamAvailable(SizeOf(IsamRingBufferRec)) + and(IsamNrOfRingBufferRecs < NrOfEMSTreePages) do begin + GetEMSMem(T1Ptr, SizeOf(IsamPageEntry)); + if T1Ptr = Nil then Exit; + InitAndInsertInRing(T2Ptr, True, T1Ptr); + T3Ptr := IsamPageEntryPtr(IsamRBufPtrToPgPtr(T2Ptr)); + FillChar(T3Ptr^, SizeOf(IsamPageEntry), 0); + T3Ptr^.RingBufferPtr := T2Ptr; + end; + end; + {$ENDIF} + {------} + procedure GetPageBuffer(MaxNrOfRecs : Word); + var + T1Ptr : IsamPageEntryPtr; + T2Ptr : IsamRingBufferRecPtr; + begin + Inc(MaxNrOfRecs, IsamNrOfRingBufferRecs); +{$IFDEF FPC} + while IsamAvailable(SizeOf(IsamPageEntry)) +{$ELSE} + while (MemAvail >=(LongInt(RoundToGranul(SizeOf(IsamRingBufferRec)) + + RoundToGranul(SizeOf(IsamPageEntry))) + Free)) + and IsamAvailable(SizeOf(IsamPageEntry)) +{$ENDIF} + and(IsamNrOfRingBufferRecs < MaxNrOfRecs) do begin + GetMem(T1Ptr, SizeOf(IsamPageEntry)); + if not IsamAvailable(SizeOf(IsamRingBufferRec)) then begin + FreeMem(T1Ptr, SizeOf(IsamPageEntry)); + Exit; + end; + InitAndInsertInRing(T2Ptr, False, T1Ptr); + FillChar(T1Ptr^, SizeOf(IsamPageEntry), 0); + T1Ptr^.RingBufferPtr := T2Ptr; + end; + end; + {------} +begin + IsamNrOfRingBufferRecs := 0; + IsamRBR1Ptr := Nil; + UseMinimumNormalHeap := Free >= MinimizeUseOfNormalHeap; + if UseMinimumNormalHeap then begin + Free := Free - MinimizeUseOfNormalHeap; + end; + {$IFDEF UseEMSHeap} + if NrOfEMSTreePages > 0 then begin + SaveEMSHeapErrorFuncPtr := EMSHeapErrorFuncPtr; + EMSHeapErrorFuncPtr := Nil; + {-Set default handling for not to use EMSMaxAvail} + GetEMSPageBuffer; + EMSHeapErrorFuncPtr := SaveEMSHeapErrorFuncPtr; + end; + {$ENDIF} + LResult := 0; {!!.51} + ILI(LResult).Hi := IsamNrOfRingBufferRecs; {!!.51} + if UseMinimumNormalHeap then begin + if IsamNrOfRingBufferRecs < MaxHeight then begin + MaxNrOfNormalHeapRecs := MaxHeight - IsamNrOfRingBufferRecs; + end + else begin + MaxNrOfNormalHeapRecs := 0; + end; + end + else begin + MaxNrOfNormalHeapRecs := 65535 - IsamNrOfRingBufferRecs; + end; + GetPageBuffer(MaxNrOfNormalHeapRecs); + ILI(LResult).Lo := IsamNrOfRingBufferRecs - ILI(LResult).Hi; {!!.51} + IsamGetPageBuffer := LResult; {!!.51} + if IsamNrOfRingBufferRecs < MaxHeight then begin + IsamReleasePageBuffer; + IsamOK := False; + IsamError := 10000; + end; +end; +{$ENDIF} + +procedure IsamGetStartingLong( IFBPtr : IsamFileBlockPtr; {!!.42} + RefNr : LongInt; + var Dest : LongInt); +var + RefPtr : LongPtr; {!!.53} + Dummy1Ptr, {!!.53} + Dummy2Ptr : IsamLockEntryRecPtr; {!!.53} + IsToUnLock : Boolean; {!!.53} +begin + {$IFDEF LockBeforeRead} + IsToUnLock := False; + with IFBPtr^, DIDPtr^[0]^ do begin + if NSP <> Nil then begin + IsamIsInLockList(@IFBPtr^.NSP^.LockEntryRec, RefNr, RefPtr, + False, Dummy1Ptr, Dummy2Ptr); {!!.42} + IsToUnLock := RefPtr = Nil; + if IsToUnLock then begin + IsamOK := btfLockMgrAcqLock(DatF.Handle, + RefNr * LenRec, SizeOf(LongInt), + 0, 0); + if not IsamOK then + IsamError := 10140; + IsToUnLock := IsamOK; + end; + end; + end; + {$ENDIF} + if IsamOK then begin + with IFBPtr^, DIDPtr^[0]^ do begin + IsamGetBlock(DatF, RefNr * LenRec, SizeOf(LongInt), Dest); + end; + end; + {$IFDEF LockBeforeRead} + if IsToUnLock then begin + with IFBPtr^, DIDPtr^[0]^ do begin + if not btfLockMgrRelLock(DatF.Handle, RefNr * LenRec, SizeOf(LongInt)) then begin + IsamOK := False; + IsamError := 10341; + end; + end; + end; + {$ENDIF} +end; + + +procedure IsamFindRecRef( IFBPtr : IsamFileBlockPtr; + var UserDatRef : LongInt; + NotFoundSearchDirection : Integer);{!!.42} +var + LongDest : LongInt; + Found : Boolean; +begin + Found := False; + if NotFoundSearchDirection = 0 then begin + IsamGetStartingLong(IFBPtr, UserDatRef, LongDest); + if IsamOK then begin + Found := LongDest = 0; + end; + end + else begin + if NotFoundSearchDirection > 0 then begin + if UserDatRef < 1 then begin + UserDatRef := 0; + end + else begin + Dec(UserDatRef); + end; + repeat + Inc(UserDatRef); + IsamGetStartingLong(IFBPtr, UserDatRef, LongDest); + if IsamOK then begin + Found := LongDest = 0; + end; + until Found or not IsamOK + or(UserDatRef = IFBPtr^.DIDPtr^[0]^.NumRec); + end + else begin + if UserDatRef > IFBPtr^.DIDPtr^[0]^.NumRec then begin + UserDatRef := Succ(IFBPtr^.DIDPtr^[0]^.NumRec); + end + else begin + Inc(UserDatRef); + end; + if UserDatRef > 1 then begin + repeat + Dec(UserDatRef); + IsamGetStartingLong(IFBPtr, UserDatRef, LongDest); + if IsamOK then begin + Found := LongDest = 0; + end; + until Found or not IsamOK or(UserDatRef = 1); + end; + end; + end; + if IsamError <> 10140 then begin + if IsamError <> 9904 then begin + IsamClearOK; + if not Found then begin + IsamOK := False; + IsamError := 10275; + end; + end; + end + else begin + IsamError := 10390; + end; +end; + + +function IsamLongIntLessEqualHighBit(L : LongInt; {!!.42} + IsLongInt : Boolean) : Word; +var + LResult : Word; {!!.51} +begin + if IsLongInt then begin + LResult := 33; {!!.51} + end + else begin + LResult := 17; {!!.51} + L := L Shl 16; + end; + repeat + if (L and $80000000) = $80000000 then begin + IsamLongIntLessEqualHighBit := LResult; {!!.51} + Exit; + end; + L := L Shl 1; + Dec(LResult); {!!.51} + until LResult = 0; {!!.51} + IsamLongIntLessEqualHighBit := 0; +end; + + +procedure IsamGetApprRecPos(IFBPtr : IsamFileBlockPtr; + var RelPos : Word; + Scale : Word; + UserDatRef : LongInt); {!!.42} +var + N : LongInt; + HighBitSum : Word; +begin + if Scale = 0 then begin + IsamOK := False; + IsamError := 10425; + Exit; + end; + N := Succ(IFBPtr^.DIDPtr^[0]^.NumRec); + if UserDatRef < 0 then + UserDatRef := 0; + if UserDatRef > N then + UserDatRef := N; + HighBitSum := IsamLongIntLessEqualHighBit(UserDatRef, True) + + IsamLongIntLessEqualHighBit(Succ(Scale), False); + if HighBitSum > 31 then begin + UserDatRef := UserDatRef Shr(HighBitSum - 31); + N := N Shr(HighBitSum - 31); + end; + RelPos := UserDatRef * Succ(Scale) Div N; +end; + + +procedure IsamGetApprRecRef( IFBPtr : IsamFileBlockPtr; + RelPos : Word; + Scale : Word; + var UserDatRef : LongInt); {!!.42} +var + N, + D : LongInt; +begin + if (Scale = 0) or(RelPos > Scale) then begin + IsamOK := False; + IsamError := 10420; + Exit; + end; + N := Succ(IFBPtr^.DIDPtr^[0]^.NumRec); + if (IsamLongIntLessEqualHighBit(N, True) + + IsamLongIntLessEqualHighBit(RelPos, False)) > 31 then begin + D :=(N Div Succ(Scale)) * RelPos; + end + else begin + D :=(N * RelPos) Div Succ(Scale); + end; + UserDatRef := D + N Div Succ(Scale) -(N Div Succ(Scale)) Shr 1; +end; + + +procedure IsamClearKey(IFBPtr : IsamFileBlockPtr; Key : Integer); +begin + with IFBPtr^.DIDPtr^[Key]^ do begin + PathInd := 0; + SequentialOK := True; + end; +end; + + +procedure IsamNextKey( IFBPtr : IsamFileBlockPtr; + Key : Word; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr ); +var + RefNr : LongInt; + IPgPtr : IsamPagePtr; + {$IFDEF ASCIIZeroKeys} + TempKeyZ : IsamKeyStr; + {$ENDIF} + {$IFDEF LengthByteKeys} + TempKeyZ : IsamKeyStr absolute UserKey; + {$ENDIF} +begin + with IFBPtr^, DIDPtr^[Key]^ do begin + if not SequentialOK then begin + if SearchForSequentialEnabled then begin + {$IFDEF ASCIIZeroKeys} + IsamMakeStrZ(UserKey, TempKeyZ); + {$ENDIF} + IsamFindKey(IFBPtr, Key, UserDatRef, TempKeyZ); + if IsamError = 0 then begin + IsamClearOK; + end + else begin + Exit; + end; + end + else begin + IsamOK := False; + IsamError := 10255; + Exit; + end; + end; + SequentialOK := False; + if PathInd = 0 then begin + RefNr := RootRef; + end + else begin + with Path [PathInd] do begin + IsamGetPage(IFBPtr, PageRef, Key, IPgPtr); + if not IsamOK then Exit; + RefNr := IPgPtr^.ItemArray [ItemArrInd].PageRef; + end; + end; + while RefNr <> 0 do begin + Inc(PathInd); + with Path [PathInd] do begin + PageRef := RefNr; + ItemArrInd := 0; + end; + IsamGetPage(IFBPtr, RefNr, Key, IPgPtr); + if not IsamOK then Exit; + RefNr := IPgPtr^.BckwPageRef; + end; + if PathInd <> 0 then begin + while(PathInd > 1) and + (Path [PathInd].ItemArrInd = IPgPtr^.ItemsOnPage) do begin + Dec(PathInd); + IsamGetPage(IFBPtr, Path [PathInd].PageRef, Key, IPgPtr); + if not IsamOK then Exit; + end; + if Path [PathInd].ItemArrInd < IPgPtr^.ItemsOnPage then begin + with Path [PathInd] do begin + Inc(ItemArrInd); + with IPgPtr^.ItemArray [ItemArrInd] do begin + IsamMakeStr(KeyStr, UserKey); + UserDatRef := DataRef; + end; + end; + end + else begin + PathInd := 0; + end; + end; + IsamOK := PathInd <> 0; + if not IsamOK then + IsamError := 10250; + SequentialOK := True; + end; +end; + + +procedure IsamFindKeyAndRef( IFBPtr : IsamFileBlockPtr; + Key : Word; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr; + NotFoundSearchDirection : Integer); +var + IPgPtr : IsamPagePtr; + {$IFDEF ASCIIZeroKeys} + TempKeyZ : IsamKeyStr; + {$ENDIF} + {$IFDEF LengthByteKeys} + TempKeyZ : IsamKeyStr absolute UserKey; + {$ENDIF} +begin + {$IFDEF ASCIIZeroKeys} + IsamMakeStrZ(UserKey, TempKeyZ); + {$ENDIF} + IsamFindKey(IFBPtr, Key, UserDatRef, TempKeyZ); + if not IsamOK and(IsamError = 0) then begin + IsamClearOK; + if NotFoundSearchDirection > 0 then begin + IsamNextKey(IFBPtr, Key, UserDatRef, UserKey); + end + else begin + if NotFoundSearchDirection < 0 then begin + with IFBPtr^, DIDPtr^[Key]^ do begin + if PathInd = 0 then begin + IsamOK := False; + IsamError := 10260; + end + else begin + with Path [PathInd] do begin + IsamGetPage(IFBPtr, PageRef, Key, IPgPtr); + if not IsamOK then Exit; + with IPgPtr^.ItemArray [ItemArrInd] do begin + UserDatRef := DataRef; + IsamMakeStr(KeyStr, UserKey); + end; + end; + end; + end; + end + else begin + IsamOK := False; + IsamError := 10270; + end; + end; + end; +end; + + +procedure IsamPrevKey( IFBPtr : IsamFileBlockPtr; + Key : Word; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr ); +var + RefNr : LongInt; + IPgPtr : IsamPagePtr; +begin + with IFBPtr^, DIDPtr^[Key]^ do begin + if not SequentialOK then begin + if SearchForSequentialEnabled then begin + IsamFindKeyAndRef(IFBPtr, Key, UserDatRef, UserKey, 0); + if not IsamOK then begin + if IsamError = 10270 then begin + IsamClearOK; + IsamFindKeyAndRef(IFBPtr, Key, UserDatRef, UserKey, -1); + end; + Exit; + end; + end + else begin + IsamOK := False; + IsamError := 10265; + Exit; + end; + end; + SequentialOK := False; + if PathInd = 0 then begin + RefNr := RootRef; + end + else begin + with Path [PathInd] do begin + IsamGetPage(IFBPtr, PageRef, Key, IPgPtr); + if not IsamOK then Exit; + Dec(ItemArrInd); + if ItemArrInd = 0 then begin + RefNr := IPgPtr^.BckwPageRef; + end + else begin + RefNr := IPgPtr^.ItemArray [ItemArrInd].PageRef; + end; + end; + end; + while RefNr <> 0 do begin + IsamGetPage(IFBPtr, RefNr, Key, IPgPtr); + if not IsamOK then Exit; + Inc(PathInd); + with Path [PathInd] do begin + PageRef := RefNr; + ItemArrInd := IPgPtr^.ItemsOnPage; + end; + with IPgPtr^ do begin + RefNr := ItemArray [ItemsOnPage].PageRef; + end; + end; + if PathInd <> 0 then begin + while(PathInd > 1) and(Path [PathInd].ItemArrInd = 0) do begin + Dec(PathInd); + IsamGetPage(IFBPtr, Path [PathInd].PageRef, Key, IPgPtr); + if not IsamOK then Exit; + end; + if Path [PathInd].ItemArrInd > 0 then begin + with IPgPtr^.ItemArray [Path [PathInd].ItemArrInd] do begin + IsamMakeStr(KeyStr, UserKey); + UserDatRef := DataRef; + end; + end + else begin + PathInd := 0; + end; + end; + IsamOK := PathInd <> 0; + if not IsamOK then + IsamError := 10260; + SequentialOK := True; + end; +end; + + +procedure IsamSearchKey( IFBPtr : IsamFileBlockPtr; + Key : Word; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr ); +var + {$IFDEF ASCIIZeroKeys} + TempKeyZ : IsamKeyStr; + {$ENDIF} + {$IFDEF LengthByteKeys} + TempKeyZ : IsamKeyStr absolute UserKey; + {$ENDIF} +begin + {$IFDEF ASCIIZeroKeys} + IsamMakeStrZ(UserKey, TempKeyZ); + {$ENDIF} + UserDatRef := 0; + IsamFindKey(IFBPtr, Key, UserDatRef, TempKeyZ); + if not IsamOK and(IsamError = 0) then begin + IsamClearOK; + IsamNextKey(IFBPtr, Key, UserDatRef, UserKey); + end; + if not IsamOK then begin + case IsamError of + 0, 10200..10299 : IsamError := 10210; + end; {Case} + end; +end; + + +procedure IsamDeleteAllKeys(IFBPtr : IsamFileBlockPtr; Key : Word); +var + IR : IsamInfoRec; +begin + IsamSetDataBufferedFlag(IFBPtr); + if not IsamOK then Exit; + with IFBPtr^ do begin + if SaveFB then begin + IsamCopyInfoRecToIR(IFBPtr, Key, IR); + IsamSaveGivenInfoRec(IFBPtr, Key, IR, -2); + if not IsamOK then Exit; + if (NSP = Nil) or IsamNetEmu then begin + IsamFlushDOSDia(IFBPtr, False); + if not IsamOK then Exit; + end; + end; + IsamDestroyPagesOfKeyNr(IFBPtr, Key); + with DIDPtr^[Key]^ do begin + NumKeys := 0; + FirstFree := -1; + NumberFree := 0; + NumRec := 0; + RootRef := 0; + PathInd := 0; + FirstFreeChanged := True; + InfoRecChanged := True; + end; + if SaveFB then begin + IsamPutInfoRec(IFBPtr, Key, False); + if not IsamOK then Exit; + if (NSP = Nil) or IsamNetEmu then + IsamFlushDOSIx(IFBPtr); + end; + end; +end; + + +procedure IsamGetApprRelPos( IFBPtr : IsamFileBlockPtr; + Key : Word; + var RelPos : Word; + Scale : Word; + UserKey : IsamKeyStr; + UserDatRef : LongInt); +var + TempL, + RefNr : LongInt; + C, K, L, R : Integer; + IPgPtr : IsamPagePtr; + Stop : Boolean; + EstEltNr, + EstNrOfElts, + RootItemNr, + ItemNrOnSecPage, + NrOfItemsOnRoot, + NrOfItemsOnSecPage, + AvgPageSizeSecLevel : Word; +begin + if Scale = 0 then begin + IsamOK := False; + IsamError := 10425; + Exit; + end; + with IFBPtr^, DIDPtr^[Key]^ do begin + if RootRef = 0 then begin + IsamOK := False; + IsamError := 10285; + Exit; + end; + AvgPageSizeSecLevel := UsedPageSize -(UsedPageSize Shr 2); + {-75% of real page contents assumed} + NrOfItemsOnSecPage := AvgPageSizeSecLevel; + RootItemNr := $FFFF; + ItemNrOnSecPage := 0; + IsamMakeStrZ(UserKey, UserKey); + Stop := False; + RefNr := RootRef; + while(RefNr <> 0) and(not Stop) do begin + IsamGetPage(IFBPtr, RefNr, Key, IPgPtr); + if not IsamOK then Exit; + with IPgPtr^ do begin + L := 1; + R := ItemsOnPage; + repeat + K :=(L + R) Shr 1; + C := IsamCompKeys(UserKey, ItemArray [K].KeyStr, + UserDatRef, ItemArray [K].DataRef, + AllowDupKeys); + if C <= 0 then + R := Pred(K); + if C >= 0 then + L := Succ(K); + until R < L; + if L - R > 1 then begin + Stop := True; + end + else begin + if R = 0 then begin + RefNr := BckwPageRef; + end + else begin + RefNr := ItemArray [R].PageRef; + end; + end; + if RootItemNr = $FFFF then begin + NrOfItemsOnRoot := ItemsOnPage; + if L - R > 1 then begin + RootItemNr := K; + end + else begin + RootItemNr := R; + end; + end + else begin + NrOfItemsOnSecPage := ItemsOnPage; + if L - R > 1 then begin + ItemNrOnSecPage := K; + end + else begin + ItemNrOnSecPage := R; + end; + Stop := True; + end; + end; + end; + end; + EstNrOfElts := Succ(AvgPageSizeSecLevel) * Succ(NrOfItemsOnRoot); + {-Includes backward references on second level(<=> 0''/items on root)} + if (ItemNrOnSecPage = 1) and(RootItemNr = 0) then begin + {-Prevent zero position from growing} + EstEltNr := 1; + end + else begin + TempL :=((LongInt(ItemNrOnSecPage) + * LongInt(Succ(AvgPageSizeSecLevel))) Shl 1) + Div LongInt(NrOfItemsOnSecPage); + EstEltNr := RootItemNr * Succ(AvgPageSizeSecLevel) + +(TempL - TempL Shr 1); + end; + RelPos := Word((LongInt(EstEltNr) * Succ(LongInt(Scale))) + Div LongInt(EstNrOfElts)); + if RelPos > Scale then + RelPos := Scale; + {-Slighly unsymethric, but simple} +end; + + +procedure IsamGetApprKeyAndRef( IFBPtr : IsamFileBlockPtr; + Key, + RelPos : Word; + Scale : Word; + var UserKey : IsamKeyStr; + var UserDatRef : LongInt); +var + EstNrOfElts, + EstEltNr, + EstRootItemNr, + EstItemNrOnSecPage, + CorItemNrOnSecPage, + AvgPageSizeSecLevel : Word; + IPgPtr : IsamPagePtr; + TempL : LongInt; +begin + if (Scale = 0) or(RelPos > Scale) then begin + IsamOK := False; + IsamError := 10420; + Exit; + end; + with IFBPtr^, DIDPtr^[Key]^ do begin + if RootRef = 0 then begin + IsamOK := False; + IsamError := 10280; + Exit; + end; + IsamGetPage(IFBPtr, RootRef, Key, IPgPtr); + if not IsamOK then Exit; + AvgPageSizeSecLevel := UsedPageSize -(UsedPageSize Shr 2); {!!.42} + {-75% of real page contents assumed} + end; + with IPgPtr^ do begin + if BckwPageRef = 0 then begin + {-No second level available} + AvgPageSizeSecLevel := 0; + end; {!!.42} + EstNrOfElts := Succ(AvgPageSizeSecLevel) * Succ(ItemsOnPage); + {-Includes backward references on second level(<=> 0''/items on root)} + EstEltNr :=(LongInt(EstNrOfElts) * LongInt(RelPos)) + Div Succ(LongInt(Scale)) + + EstNrOfElts Div Scale -(EstNrOfElts Div Scale) Shr 1; + {-Numbering starts at zero} + if EstEltNr >= EstNrOfElts then + EstEltNr := Pred(EstNrOfElts); + {-Correct estimate error} + EstRootItemNr := EstEltNr Div(Succ(AvgPageSizeSecLevel)); + EstItemNrOnSecPage := EstEltNr Mod(Succ(AvgPageSizeSecLevel)); + if (BckwPageRef = 0) or(EstItemNrOnSecPage = 0) then begin + {-No second level available} + if EstRootItemNr = 0 then begin + {-Build the smallest key} + UserKey := ''; + UserDatRef := 0; + end + else begin + with ItemArray [EstRootItemNr] do begin + IsamMakeStr(KeyStr, UserKey); + UserDatRef := DataRef; + end; + end; + Exit; + end; + if EstRootItemNr = 0 then begin + IsamGetPage(IFBPtr, BckwPageRef, Key, IPgPtr); + end + else begin + IsamGetPage(IFBPtr, ItemArray [EstRootItemNr].PageRef, Key, + IPgPtr); + end; + end; + if not IsamOK then Exit; + with IPgPtr^ do begin + {-Prevent RelPos one from decreasing} + if (EstItemNrOnSecPage = 2) and(EstRootItemNr = 0) then begin + CorItemNrOnSecPage := 2; + end + else begin + TempL :=((LongInt(EstItemNrOnSecPage) * LongInt(ItemsOnPage)) Shl 1) + Div LongInt(AvgPageSizeSecLevel); + CorItemNrOnSecPage := TempL - TempL Shr 1; + end; + if CorItemNrOnSecPage = 0 then + Inc(CorItemNrOnSecPage); + {-Slighly unsymethric, but simple} + with ItemArray [CorItemNrOnSecPage] do begin + IsamMakeStr(KeyStr, UserKey); + UserDatRef := DataRef; + end; + end; +end; + + +procedure IsamFlushFileBlock(IFBPtr : IsamFileBlockPtr); +var + DoIt : Boolean; +begin + with IFBPtr^ do begin + if SaveFB or ReadOnlyFB then Exit; {!!.50mod} + {-A save fileblock and a read only fileblock + never have data buffered} + if NSP = Nil then begin + DoIt := True; + end + else begin + DoIt := NSP^.Locked; + end; + if DoIt then begin + if NSP = Nil then begin + if DataBuffered then + IsamFlushPageInfo(IFBPtr, False); {!!.50mod} + if not IsamOK then Exit; + IsamFlushDOSDat(IFBPtr); + {$IFNDEF NoNet} + end + else begin + if DataBuffered then begin {!!.50} + IsamBuildAndPutFlagSetFlushNewData(IFBPtr); + if not IsamOK then Exit; + end; {!!.50} + IsamOnlyFlushDOSDat(IFBPtr); + if not IsamOK then Exit; + if DataBuffered then {!!.50mod} + IsamFlushDOSDia(IFBPtr, False); {!!.50mod} + {$ENDIF} + end; + if not IsamOK then Exit; + if (NrOfKeys > 0) and DataBuffered then begin {!!.50mod} + IsamFlushDOSIx(IFBPtr); + if not IsamOK then Exit; + end; + DataBuffered := False; + end; + end; +end; + + +procedure IsamFlushAllFileBlocks; +var + TPtr : IsamOpenFileBlockListPtr; +begin + TPtr := IsamOFBLPtr; + while TPtr <> Nil do begin + IsamFlushFileBlock(TPtr^.OIFBPtr); + if not IsamOK then Exit; + TPtr := TPtr^.Next; + end; +end; + + +procedure IsamDeleteFileBlock(FName : IsamFileBlockName); +var + TF : IsamFile; + DummyStr, + FNameD, + FNameI : IsamFileBlockName; +begin + IsamExtractFileNames(FName, FNameD, FNameI); + IsamExtractFileNames(FNameI, FNameI, DummyStr); + IsamAssign(TF, IsamForceExtension(FNameI, IxExtension)); + IsamDelete(TF); + IsamClearOK; + IsamAssign(TF, IsamForceExtension(FNameD, DiaExtension)); + IsamDelete(TF); + IsamClearOK; + IsamAssign(TF, IsamForceExtension(FNameD, DatExtension)); + IsamDelete(TF); +end; + + +procedure IsamCreateFileBlock(FName : IsamFileBlockName; + DatSLen : LongInt; + NumberOfKeys : Word; + IID : IsamIndDescr ); + {!!.52 rearranged} +var + TIFBPtr : IsamFileBlockPtr; + I : Integer; + DummyStr, + FNameD, + FNameI : IsamFileBlockName; + {------} + procedure UnDo(UnDoLevel : Word; Err : Integer); + begin + with TIFBPtr^ do begin + if UnDoLevel >= 3 then begin + IsamClose(IndF); + IsamDelete(IndF); + end; + if UnDoLevel >= 2 then begin + IsamClose(DatF); + IsamDelete(DatF); + end; + if UnDoLevel >= 1 then begin + IsamFreeKeyDescrMem(TIFBPtr, NumberOfKeys); + FreeMem(TIFBPtr, SizeOf(TIFBPtr^)); + end; + IsamOK := Err = 0; + IsamError := Err; + end; + end; + {------} +begin + if DatSLen < SizeOf(IsamSmallInfoRec) then + IsamError := 10020; + if (NumberOfKeys > MaxNrOfKeys) or(NumberOfKeys < 0) then + IsamError := 10050; + if not IsamGetMem(TIFBPtr, sizeof(TIFBPtr^)) then + IsamError := 10090; + if (IsamError <> 0) then + begin + IsamOK := False; + Exit; + end; + IsamDeleteFileBlock(FName); + IsamClearOK; + TIFBPtr^.NrOfKeys := NumberOfKeys; + {-for possible IsamFreeKeyDescrMem below} + IsamGetKeyDescrMem(TIFBPtr, NumberOfKeys); + if not IsamOK then begin + FreeMem(TIFBPtr, SizeOf(TIFBPtr^)); + Exit; + end; + IsamExtractFileNames(FName, FNameD, FNameI); + IsamExtractFileNames(FNameI, FNameI, DummyStr); + with TIFBPtr^ do begin + IsamAssign(DatF, IsamForceExtension(FNameD, DatExtension)); + IsamRewrite(DatF); + if not IsamOK then begin + UnDo(1, IsamError); + Exit; + end; + with DIDPtr^[0]^ do begin + FirstFree := -1; + NumberFree := 0; + NumRec := 0; + LenRec := DatSLen; + InfoRecChanged := True; + end; + IsamPutDummyBlock(DatF, 0, DIDPtr^[0]^.LenRec); + if IsamOK then + IsamPutInfoRec(TIFBPtr, 0, False); + if not IsamOK then begin + UnDo(2, IsamError); + Exit; + end; + IsamClose(DatF); + if not IsamOK then begin + UnDo(2, IsamError); + Exit; + end; + if NumberOfKeys > 0 then begin + IsamAssign(IndF, IsamForceExtension(FNameI, IxExtension)); + IsamRewrite(IndF); + if not IsamOK then begin + UnDo(2, IsamError); + Exit; + end; + MaxPages := 0; + BlockLen := 0; + for I := 1 to NumberOfKeys do begin + with DIDPtr^[I]^ do begin + KeyLen := IID [I].KeyL; + if (KeyLen < 1) or(KeyLen > MaxKeyLen) then begin + UnDo(3, 10055); + Exit; + end; + LenRec := LongInt(9 + KeyLen) * LongInt(CreatePageSize){!!.42} + + LongInt(6); + BlockOfs := BlockLen; + BlockLen := BlockLen + LenRec; + NumKeys := 0; + UsedPageSize := CreatePageSize; {!!.42} + FirstFree := -1; + NumberFree := 0; + NumRec := 0; + RootRef := 0; + AllowDupKeys := IID [I].AllowDupK; + InfoRecChanged := True; + end; + end; + IsamPutDummyBlock(IndF, 0, BlockLen); + if IsamOK then + IsamFlushPageInfo(TIFBPtr, False); + if IsamOK then + IsamClose(IndF); + if not IsamOK then begin + UnDo(3, IsamError); + Exit; + end; + end; + UnDo(1, 0); + end; +end; + + +procedure IsamOpenRawFileBlock(var IFBPtr : IsamFileBlockPtr; + FNameD, + FNameI : IsamFileBlockName; + RealNet, + ReadOnly : Boolean); + {!!.52 rearranged} +var + I : Integer; + IDID : IsamDatIndDescr; + IDIDPtr : IsamDatIndDescrPtr; + HeadOrIndCorrupted, + Dummy : Boolean; + CalcKeyL : LongInt; + {------} + procedure UnDo(Level : Word; Error : Integer); + begin + with IFBPtr^ do begin + if Level >= 4 then begin + if NrOfKeys > 0 then + IsamClose(IndF); + end; + if Level >= 3 then begin + IsamFreeKeyDescrMem(IFBPtr, NrOfKeys); + end; + if Level >= 2 then + IsamClose(DatF); + if Level >= 1 then + FreeMem(IFBPtr, SizeOf(IFBPtr^)); + end; + IsamError := Error; + IsamOK := IsamError = 0; + end; + {------} +begin + if not IsamGetMem(IFBPtr, SizeOf(IFBPtr^)) then begin {!!.52} + IsamOK := False; + IsamError := 10100; + Exit; + end; + with IFBPtr^ do begin + IsamAssign(DatF, IsamForceExtension(FNameD, DatExtension)); + IsamReset(DatF, RealNet, ReadOnly); + if not IsamOK then begin + UnDo(1, IsamError); + Exit; + end; + IDIDPtr := Addr(IDID); + DIDPtr := Addr(IDIDPtr); + {-First hold info lokally} + IsamGetInfoRec(IFBPtr, 0, HeadOrIndCorrupted); + if not IsamOK then begin + UnDo(2, IsamError); + Exit; + end; + if NrOfKeys > MaxNrOfKeys then begin + UnDo(2, 10060); + Exit; + end; + IsamGetKeyDescrMem(IFBPtr, NrOfKeys); + if not IsamOK then begin + UnDo(2, IsamError); + Exit; + end; + if NrOfKeys > 0 then begin + IsamAssign(IndF, IsamForceExtension(FNameI, IxExtension)); + IsamReset(IndF, RealNet, ReadOnly); + if not IsamOK then begin + if (IsamError <> 9901) and (IsamError <> 10110) then + IsamError := 10010; + {-Index file may be ok, if out of handles or drive not ready} + UnDo(3, IsamError); + Exit; + end; + end; + MaxPages := 0; + BlockLen := 0; + IDID.FirstFreeChanged := False; + IDID.InfoRecChanged := False; + DIDPtr^[0]^ := IDID; + {-Copy lokal info to real} + for I := 1 to NrOfKeys do begin + with DIDPtr^[I]^ do begin + BlockOfs := BlockLen; + IsamGetInfoRec(IFBPtr, I, Dummy); + if not IsamOK then begin + UnDo(4, IsamError); + Exit; + end; + if UsedPageSize > MaxPageSize then begin {!!.42} + UnDo(4, 10122); {!!.42} + Exit; {!!.42} + end; {!!.42} + CalcKeyL :=(LenRec * LongInt(10000) - LongInt(60000)) {!!.42} + Div LongInt(UsedPageSize) - LongInt(90000); + if (((CalcKeyL Div LongInt(10000)) * LongInt(10000)) <> CalcKeyL) + then begin + UnDo(4, 10120); + Exit; + end; + if (CalcKeyL >(LongInt(MaxKeylen) * LongInt(10000))) + or(CalcKeyL < LongInt(10000)) then begin + UnDo(4, 10121); + Exit; + end; + KeyLen := Word(CalcKeyL Div LongInt(10000)); + BlockLen := BlockLen + LenRec; + if NumRec > MaxPages then + MaxPages := NumRec; + PathInd := 0; + InfoRecChanged := False; + FirstFreeChanged := False; + SearchForSequentialEnabled := SearchForSequentialDefault; + SequentialOK := False; + end; + end; + if HeadOrIndCorrupted then begin + UnDo(4, 10010); + Exit; + end; + DataBuffered := False; + CharConvProc := BTNoCharConvert; {!!.50} + CCHookPtr := Nil; {!!.50} + CCDestrWrite := True; {!!.50} + IsamAddToOpenFileBlockList(IFBPtr); + if not IsamOK then begin + UnDo(4, 10100); + Exit; + end; + end; +end; + + +procedure IsamCloseRawFileBlock(var IFBPtr : IsamFileBlockPtr); +begin + with IFBPtr^ do begin + IsamDestroyPages(IFBPtr); + if NrOfKeys > 0 then + IsamClose(IndF); + IsamClose(DatF); + IsamFreeKeyDescrMem(IFBPtr, NrOfKeys); + IsamRemoveFromOpenFileBlockList(IFBPtr); + ValidSign := 0; + FreeMem(IFBPtr, SizeOf(IFBPtr^)); + IFBPtr := Nil; + end; +end; + + +procedure IsamOpenFileBlock(var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName; + ReadOnly, + AllReadOnly, + Save, + Net : Boolean); + {!!.52 rearranged} +type + DialogFileState = (Correct, Raw, ToRepair); +var + DiaFileState : DialogFileState; + DiaFile : IsamFile; + DiaFOpened, + DiaFExisted : Boolean; + FlagSet : IsamFlagSet; + FlagSetLen : Word; {!!.42} + DiaFileLen : LongInt; + Ok, + UseDiaFile, + UseLock, + RealNet : Boolean; + DummyStr, + FNameD, + FNameI : IsamFileBlockName; + TIFBPtr : IsamFileBlockPtr; + {------} + procedure UnDo(Level : Word; Error : Integer); + var + Dummy : Boolean; + begin + if Level >= 4 then begin + if Net then + FreeMem(TIFBPtr^.NSP, SizeOf(IsamNetSupport)); + end; + if Level >= 3 then begin + IsamCloseRawFileBlock(TIFBPtr); + end; + {$IFNDEF NoNet} + if Level >= 2 then begin + if UseLock then + Dummy := btfLockMgrRelLock(DiaFile.Handle, 3, 1); + end; + {$ENDIF} + if Level >= 1 then begin + if DiaFOpened then + IsamClose(DiaFile); + end; + if not DiaFExisted then begin + IsamDelete(DiaFile); + end; + if Net then begin {!!.42mod} + if Error = 10140 then + Error := 10355; + end; + IsamError := Error; + IsamOK := IsamError = 0; + end; + {------} + function CheckDiaFile : DialogFileState; + var + Len : DWORD; {!!.54} + Value : Word; + TestNr : Word; {!!.42} + Ok : Boolean; {!!.42} + begin + CheckDiaFile := ToRepair; {!!.31} + IsamLongSeekEOF(DiaFile, Len); + if not IsamOK then Exit; + if Len = 1 then begin + CheckDiaFile := Raw; + end + else begin + Value := 0; {!!.42} + IsamGetBlock(DiaFile, 1, SizeOf(Word), Value); {!!.53} + if IsamOK and(Value = 2000) then begin {!!.42} + {--Is Len correct?} {!!.42} + TestNr :=(Len - 3) Div FlagSetLen; {!!.42} + if RealNet then begin {!!.42} + Ok := TestNr > 1; {!!.42} + end + else begin {!!.42} + Ok := TestNr = 1; {!!.42} + end; {!!.42} + if Ok then begin {!!.42} + if LongInt(TestNr) * FlagSetLen =(Len - 3) then begin{!!.42} + CheckDiaFile := Correct; {!!.42} + DiaFileLen := Len; {!!.42} + Exit; {!!.42} + end; {!!.42} + end; {!!.42} + end; {!!.42} + end; + if ReadOnly and(UseDiaFile or(Len <> 1)) then begin + {-to use a dialog file in read only mode it must be correct; + if it is used in read only mode, it's length has to be 1(can + only occur in single user mode "$Define NoNet")} + IsamOK := False; + IsamError := 10440; + end; + end; + {------} +begin +{--Correct parameters} + if AllReadOnly then + ReadOnly := True; + if ReadOnly then + Save := False; + {$IFDEF NoNet} + Net := False; + {$ENDIF} + +{--Set controlling values} + RealNet :=(IsamInitializedNet <> NoNet) and Net; + UseLock := RealNet and not AllReadOnly; + if Net then begin + UseDiaFile := not AllReadOnly; + end + else begin + UseDiaFile := Save; + end; + +{--Set local values} + IsamExtractFileNames(FName, FNameD, FNameI); + IsamExtractFileNames(FNameI, FNameI, DummyStr); + +{--Open dialog file in specified mode} + IsamAssign(DiaFile, IsamForceExtension(FNameD, DiaExtension)); + DiaFExisted := True; + repeat + Ok := True; + IsamReset(DiaFile, RealNet, ReadOnly); + DiaFOpened := IsamOK; + if not IsamOK then begin + if IsamError = 9903 then begin + DiaFExisted := False; + IsamClearOK; + if UseDiaFile then begin + Ok := False; + if ReadOnly then begin + UnDo(0, 10440); + Exit; + end + else begin + IsamMakeDiaFile(DiaFile); + if IsamOK then + IsamClose(DiaFile); + if not IsamOK then begin + UnDo(0, IsamError); + Exit; + end; + end; + end; + end + else begin + UnDo(0, IsamError); + Exit; + end; + end; + until Ok; + +{--Set lock on dialog file station 0 during open} + {$IFNDEF NoNet} + if UseLock then begin + if not btfLockMgrAcqLock(DiaFile.Handle, + 3, + 1, {pretend the flag set is one byte} + IsamLockTimeOut * IsamFBLockTimeOutFactor, + IsamDelayBetwLocks) then begin + UnDo(1, 10355); + Exit; + end; + (* !!.52 this double locking code has been removed + if IsamLockRecord(3, 1, DiaFile.Handle, 0, 0) then begin {!!.42} + UnDo(2, 10480); {!!.42} + Exit; {!!.42} + end; {!!.42} + *) + end; {!!.42} + {$ENDIF} + +{--Open data and index files and read headers} + IsamOpenRawFileBlock(TIFBPtr, FNameD, FNameI, RealNet, ReadOnly); + if not IsamOK then begin + UnDo(2, IsamError); + Exit; + end; + +{--Set additional local values} + FlagSetLen := Succ(Succ(TIFBPtr^.NrOfKeys) Shr 3); + DiaFileLen := + LongInt(FlagSetLen) * Succ(LongInt(IsamDefNrOfWS)) + 3; {!!.42} + +{--Check dialog file} + if DiaFExisted then begin + DiaFileState := CheckDiaFile; + if not IsamOK then begin + UnDo(3, IsamError); + Exit; + end; + end + else begin + if UseDiaFile then begin + DiaFileState := Raw; + end + else begin + DiaFileState := Correct; + end; + end; + +{--if we open a net fileblock with corrupted dialog file, + then ensure that we are alone} + {$IFNDEF NoNet} + if (DiaFileState <> Correct) and UseLock then begin {!!.42} + if not IsamEnsureOnlyWS(DiaFile.Handle) then begin {!!.42} + UnDo(3, 10360); {!!.42} + Exit; {!!.42} + end; {!!.42} + end; {!!.42} + {$ENDIF} + +{--Set fileblock and net support data} + with TIFBPtr^ do begin + DiaF := DiaFile; + ReadOnlyFB := ReadOnly; + SaveFB := Save; + NSP := Nil; + {$IFNDEF NoNet} + if Net then begin + if not IsamGetMem(NSP, SizeOf(IsamNetSupport)) then begin{!!.52} + UnDo(3, 10356); + Exit; + end; + with NSP^ do begin + Locked := False; + ReadLocked := False; + {-FlagSetReadLocked only set or read by Isam(Entry/Exit)Code} + FlagSetReadLocked := false; {!!.51} + AllStationsReadOnly := AllReadOnly; + ReloadAll := False; + SaveFileBlockRepaired := False; + DiaLenM3 := DiaFileLen - 3; + SetLen := FlagSetLen; + SupNrOfWS := Pred(DiaLenM3 Div SetLen); {!!.42} + if RealNet and not AllStationsReadOnly then begin + IsamDetermineLocalWSNr(DiaF.Handle, LocalWSNr, + SupNrOfWS); {!!.42} + if not IsamOK then begin + UnDo(4, IsamError); + Exit; + end; + end + else begin + LocalWSNr := 0; + end; + with LockEntryRec do begin + Count := 0; + Next := Nil; + end; + end; + end; + {$ENDIF} + end; + +{--Repair fileblock and/or fill up flag sets if necessary} + if DiaFileState <> Correct then begin + {del!!.42} + {--Repair fileblock if necessary} + if DiaFileState = ToRepair then begin + IsamRepairFileBlock(TIFBPtr); + if not IsamOK then begin + {del!!.42} + UnDo(4, IsamError); + Exit; + end; + DiaFileState := Raw; + end; + + {--Fill up flag sets if necessary} + {$IFNDEF NoNet} + if Net then begin + if DiaFileState = Raw then begin + IsamFillFlagSet(TIFBPtr, FlagSet); + IsamPutFlagSet(TIFBPtr, FlagSet); + if IsamOK and Save and((not Net) or IsamNetEmu) then + IsamFlushDOSDia(TIFBPtr, False); + if not IsamOK then begin + {del!!.42} + UnDo(4, IsamError); + Exit; + end; + end; + end; + {del!!.42} + {$ENDIF} + end; + +{--Release lock on dialog file} + {$IFNDEF NoNet} + if UseLock then begin + if not btfLockMgrRelLock(TIFBPtr^.DiaF.Handle, 3, 1) then begin + UnDo(4, 10342); + Exit; + end; + end; + {$ENDIF} + +{--Close opened and not used dialog file} + if not UseDiaFile and DiaFOpened then begin + IsamClose(DiaFile); + end; + +{--Delete dialog file if not necessary} + if not(UseDiaFile or ReadOnly) and DiaFExisted then begin + IsamDelete(DiaFile); + end; + +{--Final assigns of fileblock pointer} + IFBPtr := TIFBPtr; + IFBPtr^.ValidSign := IsamFBValidSign; +end; + + +procedure IsamCloseFileBlock(var IFBPtr : IsamFileBlockPtr); +var + Ok, + UseDiaFile : Boolean; +begin + if not IsamFileBlockIsInOpenList(IFBPtr) then begin + IsamOK := False; + IsamError := 10080; + Exit; + end; + with IFBPtr^ do begin + {$IFNDEF NoNet} + if NSP <> Nil then begin + IsamUnLockAllRecs(IFBPtr); + if not IsamOK then begin + IsamError := 10323; + Exit; + end; + with NSP^ do begin + if Locked or ReadLocked then begin + ISUnLockFileBlock(IFBPtr); + if not IsamOK then begin + IsamError := 10322; + Exit; + end; + end; + end; + end; + {$ENDIF} + if ((NSP = Nil) or(IsamInitializedNet = NoNet)) and + (not(SaveFB or ReadOnlyFB)) then begin + {-Only real net and save fileblocks don't buffer} + if NrOfKeys > 0 then begin + IsamFlushPageInfo(IFBPtr, True); + if not IsamOK then Exit; + end; + IsamPutInfoRec(IFBPtr, 0, False); + if not IsamOK then Exit; + end; + + {--Point of no return} + + Ok := True; + if NSP <> Nil then begin + {$IFNDEF NoNet} + with NSP^ do begin + if LocalWSNr <> 0 then begin + IsamReleaseLocalWSNr(DiaF.Handle, LocalWSNr); + Ok := Ok and IsamOK; + end; + UseDiaFile := not AllStationsReadOnly; + end; + FreeMem(NSP, SizeOf(IsamNetSupport)); + {$ENDIF} + end + else begin + UseDiaFile := SaveFB; + end; + if UseDiaFile then begin + IsamClose(DiaF); + Ok := Ok and IsamOK; + end; + end; + IsamCloseRawFileBlock(IFBPtr); + IsamOK := Ok and IsamOK; + if not IsamOK then + IsamError := 10160; +end; + + +procedure IsamCloseAllFileBlocks; +var + T1Ptr, + TPtr : IsamOpenFileBlockListPtr; + TFBPtr : IsamFileBlockPtr; + Err : Integer; +begin + TPtr := IsamOFBLPtr; + Err := 0; + while TPtr <> Nil do begin + with TPtr^ do begin + T1Ptr := Next; + TFBPtr := OIFBPtr; + {-Must(!) be copied for TP6 heap manager compatibility; + the open fileblock list entry is removed, so the field OIFBPtr is + no longer valid afterwards(overwritten by heap internal data)} + IsamCloseFileBlock(TFBPtr); + if Err = 0 then + Err := IsamError; + IsamClearOK; + TPtr := T1Ptr; + end; + end; + IsamError := Err; + IsamOK := IsamError = 0; +end; + + +procedure IsamEntryCode(IFBPtr : IsamFileBlockPtr; Options : Word); +var + KeyNr : Byte; +begin + IsamClearOK; + if not IsamIsInitialized then begin + IsamOK := False; + IsamError := 10455; + Exit; + end; + if IsamIsCriticalActive then begin + IsamOK := False; + IsamError := 10446; + Exit; + end; + if IFBPtr = Nil then begin + IsamOK := False; + IsamError := 10445; + Exit; + end; + if IFBPtr <> Pointer(NotAFileBlockPtr) then begin + with IFBPtr^ do begin + if ValidSign <> IsamFBValidSign then begin + IsamOK := False; + IsamError := 10445; + Exit; + end; + if ((Options and OptWriteRoutine) <> 0) {!!.41} + and ReadOnlyFB then begin {!!.41} + IsamOK := False; {!!.41} + IsamError := 10065; {!!.41} + Exit; {!!.41} + end; {!!.41} + {$IFNDEF NoNet} + if (Options and OptCheckLock) <> 0 then begin + if NSP <> Nil then begin + if not NSP^.Locked then begin + IsamOK := False; + IsamError := 10398; + Exit; + end; + end; + end; + {$ENDIF} + if (Options and OptKeyRoutine) <> 0 then begin + KeyNr := Options and $00FF; + if (KeyNr < 1) or(KeyNr > NrOfKeys) then begin + IsamOK := False; + IsamError := 10164; + Exit; + end; + end; + {$IFNDEF NoNet} + if NSP <> Nil then begin + with NSP^ do begin + FlagSetReadLocked := False; + if (Options and OptReadPrefix) <> 0 then begin + if not(Locked or ReadLocked or AllStationsReadOnly) then begin + IsamReadNetPrefix(IFBPtr, False); + if not IsamOK then begin + if IsamError = 10140 then + IsamError := 10399; + Exit; + end; + FlagSetReadLocked := True; + end; + end; + end; + end; + {$ENDIF} + end; + end; + {$IFDEF UseEMSHeap} {!!.41} + if EMSHeapIsUsed then begin + if IsamOK then + IsamIsCriticalActive := True; + end; + {$ENDIF} {!!.41} +end; + + +procedure IsamExitCode(IFBPtr : IsamFileBlockPtr); +begin + if not IsamIsInitialized then Exit; + if IsamError = 10445 then Exit; + {$IFDEF UseEMSHeap} + if EMSHeapIsUsed then begin + if UserSaveEMSHandle <> 0 then begin + {$IFDEF EMSDisturbance} + OwnSaveEMSHandle := SaveEMSCtxt; + {$ENDIF} + RestoreEMSCtxt(UserSaveEMSHandle); + UserSaveEMSHandle := 0; + end; + end; + {$ENDIF} + IsamIsCriticalActive := False; + if IFBPtr <> Pointer(NotAFileBlockPtr) then begin + if IsamError = 10140 then begin + if IFBPtr^.ReadOnlyFB then + IsamError := 10397; + end; + {$IFNDEF NoNet} + if IFBPtr^.NSP <> Nil then begin + if IsamError = 10140 then + IsamError := 10397; + with IFBPtr^.NSP^ do begin + if FlagSetReadLocked then begin + if not IsamUnLockMyFlagSet(IFBPtr) then begin + IsamOK := False; + IsamError := 10341; + Exit; + end; + FlagSetReadLocked := False; + end; + end; + end; + {$ENDIF} + end; +end; + diff --git a/src/wc_sdk/isamnwrk.inc b/src/wc_sdk/isamnwrk.inc new file mode 100644 index 0000000..a3a6cb3 --- /dev/null +++ b/src/wc_sdk/isamnwrk.inc @@ -0,0 +1,807 @@ +{********************************************************************} +{* ISAMNWRK.INC - network related routines *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +procedure IsamResetIRChangedSaveN(IFBPtr : IsamFileBlockPtr); +var + I : Integer; +begin + with IFBPtr^ do begin + for I := 0 to NrOfKeys do begin + DIDPtr^[I]^.IRChangedSaveN := False; + end; + end; +end; + + +function IsamAddLockToReadLock(IFBPtr : IsamFileBlockPtr) : Boolean; +var + Dummy : Boolean; +begin + IsamAddLockToReadLock := False; + with IFBPtr^, NSP^ do begin + if LocalWSNr > 0 then begin + if not btfLockMgrAcqLock(DiaF.Handle, + 3, LocalWSNr * SetLen, + 0, 0) then Exit; + end; + if LocalWSNr < SupNrOfWS then begin + if not btfLockMgrAcqLock(DiaF.Handle, + Succ(LocalWSNr) * SetLen + 3, + (SupNrOfWS - LocalWSNr) * SetLen, + 0, 0) then begin + if LocalWSNr > 0 then begin + Dummy := btfLockMgrRelLock(DiaF.Handle, 3, LocalWSNr * SetLen); + end; + Exit; + end; + end; + end; + IsamAddLockToReadLock := True; +end; + + +procedure IsamSubLockFromReadLock(IFBPtr : IsamFileBlockPtr); +var + Dummy : Boolean; +begin + with IFBPtr^, NSP^ do begin + if LocalWSNr < SupNrOfWS then begin + Dummy := btfLockMgrRelLock(DiaF.Handle, + Succ(LocalWSNr) * SetLen + 3, + (SupNrOfWS - LocalWSNr) * SetLen); + end; + if LocalWSNr > 0 then begin + Dummy := btfLockMgrRelLock(DiaF.Handle, 3, LocalWSNr * SetLen); + end; + end; +end; + + +procedure IsamIsInLockList( FirstLEntryPtr : IsamLockEntryRecPtr; + Ref : LongInt; + var RefPtr : LongPtr; + SearchEnd : Boolean; + var LEntryPtr : IsamLockEntryRecPtr; + var PrevPtr : IsamLockEntryRecPtr); + {!!.42} +var + Found, + Stop : Boolean; + I : Integer; +begin + RefPtr := Nil; + LEntryPtr := FirstLEntryPtr; {!!.42} + PrevPtr := Nil; + Found := False; + repeat + with LEntryPtr^ do begin + I := 1; + while(I <= Count) and not Found do begin + Found := EntryArr [I] = Ref; + if Found then begin + RefPtr := @EntryArr [I]; + end + else begin + Inc(I); + end; + end; + end; + Stop := LEntryPtr^.Next = Nil; + if not(Stop or Found) then begin + PrevPtr := LEntryPtr; + LEntryPtr := LEntryPtr^.Next; + end; + until Found or Stop; + if Stop or not(Found and SearchEnd) then Exit; + repeat + Stop := LEntryPtr^.Next = Nil; + if not Stop then begin + PrevPtr := LEntryPtr; + LEntryPtr := LEntryPtr^.Next; + end; + until Stop; +end; + + +function IsamAddToLockList(FirstLEntryPtr : IsamLockEntryRecPtr; + Ref : LongInt) : Boolean; + {!!.42} +var + DummyPtr, + ILERPtr : IsamLockEntryRecPtr; + RefPtr : LongPtr; +begin + IsamAddToLockList := False; + IsamIsInLockList(FirstLEntryPtr, Ref, RefPtr, False, ILERPtr, + DummyPtr); {!!.42} + if RefPtr <> Nil then Exit; + if ILERPtr^.Count < MaxLockEntries then begin + Inc(ILERPtr^.Count); + end + else begin + if not IsamGetMem(ILERPtr^.Next, sizeof(IsamLockEntryRec)) then begin {!!.52} + IsamOK := False; + IsamError := 10337; + Exit; + end; + ILERPtr := ILERPtr^.Next; + ILERPtr^.Count := 1; + ILERPtr^.Next := Nil; + end; + ILERPtr^.EntryArr [ILERPtr^.Count] := Ref; + IsamAddToLockList := True; +end; + + +function IsamRemoveFromLockList(FirstLEntryPtr : IsamLockEntryRecPtr; + Ref : LongInt) : Boolean; + {!!.42} +var + PrevPtr, + ILERPtr : IsamLockEntryRecPtr; + RefPtr : LongPtr; +begin + IsamRemoveFromLockList := False; + IsamIsInLockList(FirstLEntryPtr, Ref, RefPtr, True, ILERPtr, + PrevPtr); {!!.42} + if RefPtr = Nil then Exit; + with ILERPtr^ do begin + RefPtr^ := EntryArr [Count]; + Dec(Count); + if(Count = 0) and(PrevPtr <> Nil) then begin + PrevPtr^.Next := Nil; + FreeMem(ILERPtr, SizeOf(IsamLockEntryRec)); + end; + end; + IsamRemoveFromLockList := True; +end; + + +procedure ISLockRec(IFBPtr : IsamFileBlockPtr; Ref : LongInt); +begin + with IFBPtr^, DIDPtr^[0]^ do begin + if not IsamAddToLockList(@IFBPtr^.NSP^.LockEntryRec, Ref) + then Exit; {!!.42} + {-Either record is already locked or heap space doen't suffice} + IsamOK := btfLockMgrAcqLock(DatF.Handle, + Ref * LenRec, SizeOf(LongInt), + IsamLockTimeOut, IsamDelayBetwLocks); + if not IsamOK then begin + if IsamRemoveFromLockList(@IFBPtr^.NSP^.LockEntryRec, Ref) + then; {!!.42} + IsamError := 10335; + end; + end; +end; + + +procedure ISUnLockRec(IFBPtr : IsamFileBlockPtr; Ref : LongInt); +begin + with IFBPtr^, DIDPtr^[0]^ do begin + if not IsamRemoveFromLockList(@IFBPtr^.NSP^.LockEntryRec, Ref) + then Exit; {!!.42} + {-Already unlocked} + IsamOK := btfLockMgrRelLock(DatF.Handle, Ref * LenRec, SizeOf(LongInt)); + if not IsamOK then + IsamError := 10345; + {-No attempt is made to mark the lock again, the system forgot this + lock, what is an hard error} + end; +end; + + +procedure IsamUnLockAllRecs(IFBPtr : IsamFileBlockPtr); +begin + with IFBPtr^, NSP^, LockEntryRec do begin + while Count > 0 do begin + ISUnLockRec(IFBPtr, EntryArr [1]); + if not IsamOK then Exit; + end; + end; +end; + + +function IsamLockAllFlagSets(IFBPtr : IsamFileBlockPtr) : Boolean; +begin + IsamLockAllFlagSets := + btfLockMgrAcqLock(IFBPtr^.DiaF.Handle, + 3, + IFBPtr^.NSP^.DiaLenM3, + IsamLockTimeOut * IsamFBLockTimeOutFactor, + IsamDelayBetwLocks); +end; + + +function IsamUnLockAllFlagSets(IFBPtr : IsamFileBlockPtr) : Boolean; +begin + IsamUnLockAllFlagSets := + btfLockMgrRelLock(IFBPtr^.DiaF.Handle, 3, IFBPtr^.NSP^.DiaLenM3); +end; + + +procedure IsamLockMyFlagSet(IFBPtr : IsamFileBlockPtr); +begin + with IFBPtr^, NSP^ do begin + IsamOK := btfLockMgrAcqLock(DiaF.Handle, + LongInt(LocalWSNr) * LongInt(SetLen) + LongInt(3), + SetLen, + IsamLockTimeOut, + IsamDelayBetwLocks); + if not IsamOK then + IsamError := 10140; + end; +end; + + +function IsamUnLockMyFlagSet(IFBPtr : IsamFileBlockPtr) : Boolean; +begin + with IFBPtr^, NSP^ do begin + IsamUnLockMyFlagSet := + btfLockMgrRelLock(DiaF.Handle, + LongInt(LocalWSNr) * LongInt(SetLen) + LongInt(3), + SetLen); + end; +end; + + +procedure IsamFillFlagSet(IFBPtr : IsamFileBlockPtr; + var FlagSet : IsamFlagSet); +begin + FillChar(FlagSet, IFBPtr^.NSP^.SetLen, $FF); +end; + + +procedure IsamResetMyFlagSet(IFBPtr : IsamFileBlockPtr); +var + FlagSet : IsamFlagSet; +begin + with IFBPtr^, NSP^ do begin + FillChar(FlagSet, SetLen, 0); + IsamPutBlock(DiaF, + LongInt(LocalWSNr) * LongInt(SetLen) + LongInt(3), + SetLen, FlagSet); + end; +end; + + +procedure IsamBuildFlagSet(IFBPtr : IsamFileBlockPtr; + var FlagSet : IsamFlagSet ); +var + I : Integer; +begin + with IFBPtr^, NSP^ do begin + if SaveFileBlockRepaired then begin + SaveFileBlockRepaired := False; + IsamFillFlagSet(IFBPtr, FlagSet); + Exit; + end; + if DataBuffered then begin + FlagSet := [Succ(NrOfKeys)]; + for I := 0 to NrOfKeys do begin + with DIDPtr^[I]^ do begin + if InfoRecChanged or IRChangedSaveN then + FlagSet := FlagSet + [I]; + end; + end; + end + else begin + FlagSet := []; + end; + end; +end; + + +procedure IsamPutFlagSet(IFBPtr : IsamFileBlockPtr; + var FlagSet : IsamFlagSet ); +{$IFDEF VER60} {!!.53} +type {!!.53} + SmallInt = integer; {!!.53} +{$ENDIF} {!!.53} +{$IFDEF VER70} {!!.53} +type {!!.53} + SmallInt = integer; {!!.53} +{$ENDIF} {!!.53} +{$IFDEF VER15} {!!.53} +type {!!.53} + SmallInt = integer; {!!.53} +{$ENDIF} {!!.53} +var + BufRec : packed Record + IST : SmallInt; {Integer;} {!!.53} + Buffer : Array [0..512] Of Byte; + end; + I, + BufInd, + MaxBuf, + AktWs, + RestWs : Word; + FSComp, + EndOfPut, + StartOfPut : Boolean; + BufCont, + DiaPos : LongInt; + FS : Array [0..31] Of Byte Absolute FlagSet; + {------} + function FlagSetComplete : Boolean; + var + I : Integer; + begin + FlagSetComplete := False; + for I := 0 to IFBPtr^.NrOfKeys do begin + if not (I in FlagSet) then Exit; + end; + FlagSetComplete := True; + end; + {------} +begin + with IFBPtr^, NSP^, BufRec do begin + IST := 2000; {net info} + Buffer [0] := 0; {net emulation} + BufInd := SetLen; {at least 1 Byte free} + StartOfPut := True; + EndOfPut := False; + MaxBuf := SizeOf(Buffer) Div SetLen; + AktWs := 1; + DiaPos := 3; + RestWs := Succ(SupNrOfWS); + FSComp := FlagSetComplete; + repeat + if RestWs > MaxBuf then begin + BufCont := LongInt(MaxBuf) * LongInt(SetLen); + end + else begin + BufCont := LongInt(RestWs) * LongInt(SetLen); + EndOfPut := True; + end; + if not FSComp then begin + IsamGetBlock(DiaF, DiaPos, BufCont, Buffer); + if not IsamOK then Exit; + end; + while BufInd < ILI(BufCont).Lo do begin + if AktWs = LocalWSNr then begin + FillChar(Buffer [BufInd], SetLen, 0); + end + else begin + for I := BufInd to Pred(BufInd + SetLen) do begin + Buffer [I] := Buffer [I] or FS [I-BufInd]; + end; + end; + BufInd := BufInd + SetLen; + Inc(AktWs); + end; + BufInd := 0; + if StartOfPut then begin + StartOfPut := False; + IsamPutBlock(DiaF, 1, 2, IST); {!!.53} + IsamPutBlock(DiaF, 3, BufCont, Buffer); {!!.53} + end + else begin + IsamPutBlock(DiaF, DiaPos, BufCont, Buffer); + end; + if EndOfPut or not IsamOK then Exit; + DiaPos := DiaPos + BufCont; + RestWs := RestWs - MaxBuf; + until False; + end; +end; + + +procedure IsamBuildAndPutFlagSetFlushNewData(IFBPtr : IsamFileBlockPtr); +var + FlagSet : IsamFlagSet; + ModMark : Boolean; +begin + with IFBPtr^ do begin + if SaveFB then begin + IsamFillFlagSet(IFBPtr, FlagSet); + DIDPtr^[0]^.InfoRecChanged := False; + end + else begin + if not DataBuffered then Exit; + IsamBuildFlagSet(IFBPtr, FlagSet); + IsamFlushPageInfo(IFBPtr, False); + if not IsamOK then Exit; + if DIDPtr^[0]^.InfoRecChanged or DIDPtr^[0]^.IRChangedSaveN then begin + IsamPutInfoRec(IFBPtr, 0, False); + if not IsamOK then Exit; + DIDPtr^[0]^.InfoRecChanged := False; + end + else begin + ModMark := False; + IsamPutBlock(DatF, 20, 1, ModMark); + if not IsamOK then Exit; + end; + end; + end; + IsamPutFlagSet(IFBPtr, FlagSet); + if (IFBPtr^.NSP = Nil) or IsamNetEmu then begin {!!.56} + IsamFlushDOSDia(IFBPtr, True); {!!.56} + end; {!!.56} +end; + +procedure IsamGetFlagSet(var IFBPtr : IsamFileBlockPtr; + var FlagSet : IsamFlagSet; + var Valid : Boolean; + ReadOnce : Boolean); +var + Buffer : packed Record + Dummy : Byte; + Value : Word; + Buf : Array [0..508] Of Byte; + end; + NrToRead : Word; +begin + with IFBPtr^, NSP^ do begin + if false {ReadOnce} then begin + NrToRead := Succ(LongInt(LocalWSNr)) * LongInt(SetLen) + + LongInt(3); + if NrToRead <= SizeOf(Buffer) then begin + IsamGetBlock(DiaF, 0, NrToRead, Buffer); + if not IsamOK then Exit; + Valid := Buffer.Value = 2000; + if not Valid then Exit; + Move(Buffer.Buf [LongInt(LocalWSNr) * LongInt(SetLen)], + FlagSet, SetLen); + end + else begin + ReadOnce := False; + end; + end; + if true {not ReadOnce} then begin + IsamGetBlock(DiaF, 0, 3, Buffer); + if not IsamOK then Exit; + Valid := Buffer.Value = 2000; + if not Valid then Exit; + IsamGetBlock(DiaF, LongInt(LocalWSNr) * LongInt(SetLen) + + LongInt(3), SetLen, FlagSet); + end; + end; +end; + + +procedure IsamLockAndGetFlagSet(IFBPtr : IsamFileBlockPtr; + var FlagSet : IsamFlagSet; + var Valid : Boolean ); +begin + IsamLockMyFlagSet(IFBPtr); + if not IsamOK then Exit; + IsamGetFlagSet(IFBPtr, FlagSet, Valid, False); + if not IsamOK then {!!.54} + if not IsamUnLockMyFlagSet(IFBPtr) then {!!.54} + {do nothing}; {!!.54} +end; + + +procedure IsamReactOnFlagSet(IFBPtr : IsamFileBlockPtr; + var FlagSet : IsamFlagSet); +var + Dummy : Boolean; + I : Integer; +begin + with IFBPtr^ do begin + if not(Succ(NrOfKeys) in FlagSet) then Exit; + if not ReadOnlyFB then + IsamResetMyFlagSet(IFBPtr); + if not IsamOK then begin + NSP^.ReloadAll := True; + Exit; + end; + for I := 0 to NrOfKeys do begin + if I in FlagSet then begin + IsamGetInfoRec(IFBPtr, I, Dummy); + if not IsamOK then begin + NSP^.ReloadAll := True; + Exit; + end; + if I > 0 then begin + with DIDPtr^[I]^ do begin + SequentialOK := False; + if NumRec > MaxPages then begin + MaxPages := NumRec; + end; + end; + IsamDestroyPagesOfKeyNr(IFBPtr, I); + end; + end; + end; + end; +end; + + +procedure IsamReadNetPrefix(IFBPtr : IsamFileBlockPtr; + Locked : Boolean ); +var + Dummy, + Valid : Boolean; + FlagSet : IsamFlagSet; + {------} + procedure UnDo(Error : Integer); + begin + if not Locked then begin + Dummy := IsamUnLockMyFlagSet(IFBPtr); + IsamSubLockFromReadLock(IFBPtr); + end; + IsamOK := False; + IsamError := Error; + end; + {------} +begin + if Locked then begin + IsamGetFlagSet(IFBPtr, FlagSet, Valid, True); + end + else begin + IsamLockAndGetFlagSet(IFBPtr, FlagSet, Valid); + end; + if IsamError = 10140 then begin + UnDo(IsamError); + Exit; + end; + if not (Valid and IsamOK) then begin + IsamClearOK; + if not Locked then begin + if not IsamAddLockToReadLock(IFBPtr) then begin + UnDo(10330); + Exit; + end; + end; + IsamRepairFileBlock(IFBPtr); + if not IsamOK then begin + UnDo(IsamError); + Exit; + end; + IsamFillFlagSet(IFBPtr, FlagSet); + IsamReactOnFlagSet(IFBPtr, FlagSet); + if not IsamOK then begin + UnDo(IsamError); + Exit; + end; + if Locked and IFBPtr^.SaveFB then begin + IFBPtr^.NSP^.SaveFileBlockRepaired := True; + end + else begin + IsamPutFlagSet(IFBPtr, FlagSet); + if not IsamOK then begin + UnDo(IsamError); + Exit; + end; + end; + if not Locked then + IsamSubLockFromReadLock(IFBPtr); + Exit; + end; + with IFBPtr^.NSP^ do begin + if ReloadAll then begin + IsamFillFlagSet(IFBPtr, FlagSet); + ReloadAll := False; + end; + end; + IsamReactOnFlagSet(IFBPtr, FlagSet); + if not IsamOK then {!!.54} + UnDo(IsamError); {!!.54} +end; + + +procedure ISReadLockFileBlock(IFBPtr : IsamFileBlockPtr); +begin + if IFBPtr^.NSP <> Nil then begin + with IFBPtr^, NSP^ do begin + if not AllStationsReadOnly then begin + if not ReadLocked then begin + if Locked then begin + if not ReadOnlyFB then begin + IsamBuildAndPutFlagSetFlushNewData(IFBPtr); + end; + if IsamOK then begin + IsamOK := IsamUnLockAllFlagSets(IFBPtr); + if not IsamOK then begin + IsamError := 10340; + end + else begin + Locked := False; + if not IsamNetEmu then + DataBuffered := False; + end; + end; + end; + if IsamOK and not Locked then begin + IsamReadNetPrefix(IFBPtr, False); + if IsamOK then begin + ReadLocked := True; + end + else begin + if IsamError = 10140 then + IsamError := 10332; + end; + end; + end; + end; + end; + end; +end; + + +procedure ISLockFileBlock(IFBPtr : IsamFileBlockPtr); +var + Dummy : Boolean; +begin + if IFBPtr^.NSP <> Nil then begin + with IFBPtr^, NSP^ do begin + if not AllStationsReadOnly then begin + if not Locked then begin + if ReadLocked then begin + if IsamUnLockMyFlagSet(IFBPtr) then begin + ReadLocked := False; + end + else begin + IsamOK := False; + IsamError := 10340; + end; + end; + if IsamOK and not ReadLocked then begin + if IsamLockAllFlagSets(IFBPtr) then begin + IsamReadNetPrefix(IFBPtr, True); + if not IsamOK then begin + Dummy := IsamUnLockAllFlagSets(IFBPtr); + end; + end + else begin + IsamOK := False; + IsamError := 10330; + end; + end; + if IsamOK then begin + if SaveFB then begin + IsamReduceDiaFile(IFBPtr); + if not IsamOK then begin + Dummy := IsamUnLockAllFlagSets(IFBPtr); + end; + end; + if IsamOK then begin + Locked := True; + IsamResetIRChangedSaveN(IFBPtr); + end; + end; + end; + end; + end; + end; +end; + + +procedure ISUnLockFileBlock(IFBPtr : IsamFileBlockPtr); +begin + if IFBPtr^.NSP <> Nil then begin + with IFBPtr^, NSP^ do begin + if not AllStationsReadOnly then begin + if not Locked then begin + if ReadLocked then begin + if IsamUnLockMyFlagSet(IFBPtr) then begin + ReadLocked := False; + end + else begin + IsamOK := False; + IsamError := 10340; + end; + end; + end + else begin + if not ReadOnlyFB then begin + IsamBuildAndPutFlagSetFlushNewData(IFBPtr); + end; + if IsamOK then begin + if IsamUnLockAllFlagSets(IFBPtr) then begin + Locked := False; + if not IsamNetEmu then + DataBuffered := False; + end + else begin + IsamOK := False; + IsamError := 10340; + end; + end; + end; + end; + end; + end; +end; + + +procedure ISUnLockAllOpenFileBlocks; +var + TPtr : IsamOpenFileBlockListPtr; + Err : Integer; + OK : Boolean; +begin + OK := True; + TPtr := IsamOFBLPtr; + while TPtr <> Nil do begin + ISUnLockFileBlock(TPtr^.OIFBPtr); + if not IsamOK then + Err := IsamError; + OK := OK and IsamOK; + TPtr := TPtr^.Next; + end; + if not OK then begin + IsamOK := False; + IsamError := Err; + end; +end; + + +procedure IsamReleaseLocalWSNr(FHandle, LocalWSNr : Word); +const + StartPos = $7FFFFFFF; +begin + if not btfLockMgrRelLock(FHandle, StartPos - LocalWSNr, 1) then begin + IsamOK := False; + IsamError := 10341; + end; +end; + + +procedure IsamDetermineLocalWSNr( FHandle : Word; + var LocalWSNr : Word; + SupNrOfWS : Word); {!!.42} +const + StartPos = $7FFFFFFF; +var + FirstPos : Word; +begin + if SupNrOfWS <> 0 then begin {!!.42} + Randomize; + FirstPos := Succ(Random(SupNrOfWS)); {!!.42} + LocalWSNr := FirstPos; + repeat + if btfLockMgrAcqLock(FHandle, StartPos - LocalWSNr, 1, 0, 0) then Exit; + Dec(LocalWSNr); + if LocalWSNr = 0 then + LocalWSNr := SupNrOfWS; {!!.42} + until LocalWSNr = FirstPos; + end; + IsamOK := False; + IsamError := 10306; +end; + + +function IsamEnsureOnlyWS(FHandle : Word) : Boolean; {!!.42} +const + StartPos = $7FFFFFFF; + MaxWS = $FFFE; +var + OnlyWS : Boolean; +begin + OnlyWS := btfLockMgrAcqLock(FHandle, StartPos - MaxWS, Succ(MaxWS), 0, 0); + if OnlyWS then + if btfLockMgrRelLock(FHandle, StartPos - MaxWS, Succ(MaxWS)) then + {do nothing}; + IsamEnsureOnlyWS := OnlyWS; +end; + diff --git a/src/wc_sdk/isamtool.pas b/src/wc_sdk/isamtool.pas new file mode 100644 index 0000000..6d06072 --- /dev/null +++ b/src/wc_sdk/isamtool.pas @@ -0,0 +1,874 @@ +{********************************************************************} +{* ISAMTOOL.PAS - various tool routines *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + +{$IFDEF Win32} +{$H-} {no long string routines} +{$ENDIF} + +{--Definition of possible languages for error messages of IsamErrormessage } +{ $DEFINE GermanMessage} +{$DEFINE EnglishMessage} + {-Adding a space before the $ sign of the DEFINE deactivates the error + messages of this language} + +Unit + IsamTool; + +Interface + +Uses +{$IFDEF Windows} + WinProcs, +{$ELSE} +{$IFDEF Win32} + Windows, +{$ELSE} + BaseSupp, +{$ENDIF} +{$ENDIF} + BTBase, + BTIsBase, + Filer; {!!.TP} + +Type + UsedErrorMessages = ( NoMsg, German, English ); + +Const + UseErrorMessage : UsedErrorMessages = + {$IFDEF EnglishMessage} + English; + {$ELSE} + {$IFDEF GermanMessage} + German; + {$ELSE} + NoMsg; + {$ENDIF} + {$ENDIF} + + Procedure ExtendHandles ( NumHandles : Word ); + {-Extends the number of file handles available to this application} + + Function IsamErrorMessage ( ErrorNr : Integer ) : String; + {-Returns an error describing string} + +{$IFDEF LengthByteKeys} + Procedure InvertString ( Var Dest : String; + Source : String; + MaxLen : Byte ); + {-Inverts the string Source under a maximum length of MaxLen returning + the result in Dest} +{$ENDIF} +{$IFDEF ASCIIZeroKeys} + Procedure InvertString ( Var Dest; + Var Source; + MaxLen : Byte ); + {-Inverts the null terminated array of character Source under a + maximum length of MaxLen returning the result in Dest} +{$ENDIF} + + +Implementation + +{$IFDEF Win32} + Procedure ExtendHandles ( NumHandles : Word ); + {-Extends the number of file handles available to this application} + + Begin + If SetHandleCount ( NumHandles ) < NumHandles Then Begin {!!.51} + IsamOK := False; + IsamError := 10192; + End; + End; +{$ELSE} +{$IFDEF Windows} + Procedure ExtendHandles ( NumHandles : Word ); + {-Extends the number of file handles available to this application} + + Begin + If SetHandleCount ( NumHandles ) < NumHandles Then Begin {!!.51} + IsamOK := False; + IsamError := 10192; + End; + End; +{$ELSE} +{$IFDEF FPC} + Procedure ExtendHandles ( NumHandles : Word ); + {-Extends the number of file handles available to this application} + Var + IRR : GenRegisters; + Begin + IsamClearOK; + If NumHandles >= 255 Then NumHandles := 254; + DefaultRegisters ( IRR ); + With IRR Do Begin + AX := $6700; + BX := NumHandles; + CallMsDos ( IRR ); + If Odd (Flags) Then Begin + IsamOK := False; + IsamError := 10192; + End; + End; + End; +{$ELSE} + Procedure ExtendHandles ( NumHandles : Word ); + {-Extends the number of file handles available to this application} + {$IFNDEF DPMI} + Const + Safety = 16; {Bytes of overhead for new handle table} + + Type + SegOfs = Record {Structure of a pointer} + O, S : Word; + End; + {$ENDIF} + + Var + ParasNeeded : Word; + IRR : GenRegisters; + FirstTrial, + Continue : Boolean; + + + {$IFNDEF DPMI} + Function FreeRamInParas : Word; + {-Returns the number of free paragraphs of RAM available to DOS} + Var + IRR : GenRegisters; + + Begin + DefaultRegisters ( IRR ); + With IRR Do Begin + AX := $4800; + BX := $FFFF; + If IsamDOSError = 0 Then IsamDOSFunc := AX; + CallMsDos ( IRR ); + If Odd (Flags) And (IsamDOSError = 0) Then IsamDOSError := AX; + FreeRamInParas := BX; + End; + End; + + + Function SetBlock ( Var Paragraphs : Word ) : Boolean; + {-Change size of DOS memory block allocated to this program} + Var + IRR : GenRegisters; + + Begin + DefaultRegisters ( IRR ); + With IRR Do Begin + AX := $4A00; + ES := PrefixSeg; + BX := Paragraphs; + If IsamDOSError = 0 Then IsamDOSFunc := AX; + CallMsDos ( IRR ); + Paragraphs := BX; + If Odd (Flags) And (IsamDOSError = 0) Then IsamDOSError := AX; + SetBlock := Not Odd (Flags); + End; + End; + + + Function PtrDiff ( H, L : Pointer ) : LongInt; + {-Return the number of bytes between H^ and L^. H is the higher address} + Var + High : SegOfs Absolute H; + Low : SegOfs Absolute L; + + Begin + PtrDiff := (LongInt (High.S) Shl 4 + High.O) + - (LongInt (Low.S) Shl 4 + Low.O); + End; + + + Function GetDosMemory ( Paras : Word ) : Boolean; + {-Shrinks the heap to provide Paras free DOS memory} + Var + ParasToGive : Word; + ParasToKeep : Word; + + Begin + GetDosMemory := False; + + {--Paragraphs we want to give away} + ParasToGive := Succ (Paras); + + {--Assure space free at top of heap} + If PtrDiff ( HeapEnd, HeapPtr ) Shr 4 < ParasToGive Then Exit; + + {--Deallocate memory for DOS} + ParasToKeep := SegOfs (HeapEnd).S - PrefixSeg - ParasToGive; + If Not SetBlock ( ParasToKeep ) Then Exit; + + {--Adjust end of heap down} + HeapEnd := Ptr (SegOfs (HeapEnd).S - ParasToGive, 0); + + {--Adjust the PSP record of the top of memory} + MemW [PrefixSeg:2] := SegOfs (HeapEnd).S; + + GetDosMemory := True; + End; + {$IFDEF VER55} + Function GetDosMemory ( Paras : Word ) : Boolean; + {-Shrinks the heap to provide Paras free DOS memory} + Var + TopOfHeap : Pointer; + NewFreePtr : Pointer; + ParasWeHave : Word; + ParasToGive : Word; + FreeListSize : Word; + + + Function EndOfHeap : Pointer; + {-Returns a pointer to the end of the free list} + Var + FreeSegOfs : SegOfs Absolute FreePtr; + + Begin + If FreeSegOfs.O = 0 Then Begin + {-The free list is empty, add $1000 to the segment} + EndOfHeap := Ptr (FreeSegOfs.S+$1000, 0) + End Else Begin + EndOfHeap := Ptr (FreeSegOfs.S + (FreeSegOfs.O Shr 4), 0); + End; + End; + + + Begin + GetDosMemory := False; + + {--Pointer to next address past program} + TopOfHeap := Ptr (SegOfs (FreePtr).S + $1000, 0); + + {--Paragraphs currently allocated to program} + ParasWeHave := SegOfs (TopOfHeap).S - PrefixSeg; + + {--Paragraphs we want to give away} + ParasToGive := Succ (Paras); + + {--Assure space free at top of heap} + If PtrDiff ( EndOfHeap, HeapPtr ) Shr 4 < ParasToGive Then Exit; + + {--Size of free list to move} + FreeListSize := PtrDiff ( TopOfHeap, EndOfHeap ); + + {--Adjust free list down} + NewFreePtr := Ptr (SegOfs (FreePtr).S - ParasToGive, SegOfs (FreePtr).O); + If FreeListSize > 0 Then Move ( FreePtr^, NewFreePtr^, FreeListSize ); + FreePtr := NewFreePtr; + + {--Deallocate memory for DOS} + Dec ( ParasWeHave, ParasToGive ); + If Not SetBlock ( ParasWeHave ) Then Exit; + + {--Adjust the PSP record of the top of memory} + MemW [PrefixSeg:2] := SegOfs (FreePtr).S + $1000; + + GetDosMemory := True; + End; + {$ENDIF} + {$ENDIF} + + + Begin + IsamClearOK; + + {!!.41 removed NumHandles <= 20} + + {--Assure this service is available} + DefaultRegisters ( IRR ); + With IRR Do Begin + AX := $3000; + If IsamDOSError = 0 Then IsamDOSFunc := AX; + CallMsDos ( IRR ); + {-DOS 3.3 or greater?} + If Odd (Flags) And (IsamDOSError = 0) Then IsamDOSError := AX; + If Swap ( AX ) < $031E Then Begin + IsamOK := False; + IsamError := 10190; + Exit; + End; + End; + + If NumHandles >= 255 Then NumHandles := 254; + + {$IFNDEF DPMI} + {--Calculate number of paragraphs needed (plus small safety margin)} + ParasNeeded := (Word (Succ (NumHandles)) + Safety + 15) Shr 4; + + If ParasNeeded > FreeRamInParas Then Begin + {-Not enough free DOS RAM, so shrink the heap} + If Not GetDosMemory ( ParasNeeded ) Then Begin + IsamOK := False; + IsamError := 10191; + Exit; + End; + End; + {$ENDIF} + + FirstTrial := True; + Continue := True; + While Continue Do Begin + DefaultRegisters ( IRR ); + With IRR Do Begin + AX := $6700; + BX := NumHandles; + If IsamDOSError = 0 Then IsamDOSFunc := AX; + CallMsDos ( IRR ); + If Odd (Flags) Then Begin + If IsamDOSError = 0 Then IsamDOSError := AX; + If FirstTrial Then Begin + IsamClearOK; + End Else Begin + IsamOK := False; + IsamError := 10192; + Continue := False; + End; + End Else Begin + Continue := False; + End; + End; + FirstTrial := False; + + {--Adjust for DOS 3.3 bug - number of handles must either be even or odd, + depending on the origin} + Inc (NumHandles); + End; + End; +{$ENDIF FPC} +{$ENDIF} +{$ENDIF} + + Function IsamErrorMessage ( ErrorNr : Integer ) : String; + {-Returns an error describing string} + + Var + S : String [10]; + + Begin + Case UseErrorMessage Of + NoMsg : Begin + IsamErrorMessage := ''; + End; + {$IFDEF GermanMessage} + German : Begin + Case ErrorNr Of + 9500..9899 : Begin + Str ( ErrorNr - 9500 : 0, S ); + IsamErrorMessage := 'DOS Fehlercode <' + S + '>'; + End; + 9900 : IsamErrorMessage := 'Falscher Pfadname'; + 9901 : IsamErrorMessage := 'Zu viele offene Dateien'; + 9903 : IsamErrorMessage := 'Datei nicht gefunden'; + 9904 : IsamErrorMessage := 'Falsche Dateikennzeichnung (Handle)'; + 9908 : IsamErrorMessage := 'Falscher Zugriffscode (open handle)'; + 10000 : IsamErrorMessage := + 'Seitenpuffer ist kleiner als MaxHeight'; + 10001.. + 10009 : IsamErrorMessage := 'Schwerer IO-Fehler im Save-Modus'; + 10010 : IsamErrorMessage := + 'Dateidefekt, der durch Reindizieren zu beheben ist'; + 10020 : IsamErrorMessage := + 'Datensatz kleiner als 22 Bytes oder mehr als 2147483647 Bytes'; + 10030 : IsamErrorMessage := + 'Zu wenig Speicherplatz (Fileblock-Beschreiber)'; + 10040 : IsamErrorMessage := 'Nicht genug Speicher vorhanden'; + 10050 : IsamErrorMessage := 'Falsche Anzahl Keys'; + 10055, + 10125 : IsamErrorMessage := 'Key zu lang'; + 10060 : IsamErrorMessage := + 'Zu viele Keys oder Datei-Lesefehler'; + 10065 : IsamErrorMessage := {!!.41} + 'Schreibversuch in Nur-Lese-Fileblock'; + 10070 : IsamErrorMessage := 'Datei-Lesefehler'; + 10075 : IsamErrorMessage := 'Datei-Schreibfehler'; + 10080 : IsamErrorMessage := 'Fileblock nicht offen'; + 10090, + 10100, + 10356 : IsamErrorMessage := 'Zu wenig Speicherplatz (Fileblock)'; + 10110 : IsamErrorMessage := 'Laufwerk nicht bereit'; + 10120 : IsamErrorMessage := 'PageSize nicht zutreffend'; + 10121 : IsamErrorMessage := 'MaxKeyLen zu klein'; + 10122 : IsamErrorMessage := 'MaxPageSize zu klein'; {!!.42} + 10130, + 10135 : IsamErrorMessage := 'Record 0 darf nicht benutzt werden'; + 10140 : IsamErrorMessage := + 'Zugriff verweigert, undefinierter Fehler'; + 10150 : IsamErrorMessage := 'Zu wenig Handles (Flush im Netz)'; + 10160 : IsamErrorMessage := 'Fileblock nicht korrekt geschlossen'; + 10164 : IsamErrorMessage := 'Falsche Key-Nummer'; + 10170 : IsamErrorMessage := 'Konsistenz des Fileblocks in Gefahr'; + 10180 : IsamErrorMessage := + 'Reparatur-Versuch des Fileblocks gescheitert'; + 10190 : IsamErrorMessage := 'DOS-Version 3.3 notwendig'; + 10191 : IsamErrorMessage := + 'Zu wenig Speicher, um neue Dateitabelle anzulegen'; + 10192 : IsamErrorMessage := + 'Initialisierung der neuen Dateitabelle gescheitert'; + 10200 : IsamErrorMessage := 'Kein passender Key gefunden'; + 10205 : IsamErrorMessage := 'Datensatz momentan gesperrt'; + 10210 : IsamErrorMessage := + 'Dieser und kein nachfolgender Key vorhanden'; + 10215 : IsamErrorMessage := + 'Reindizieren gescheitert, die Datendatei ist inkonsistent'; + {!!.50} + 10220 : IsamErrorMessage := 'Zu entfernender Key nicht gefunden'; + 10230 : IsamErrorMessage := + 'Doppelter Key kann nicht eingetragen werden'; + 10240, + 10250 : IsamErrorMessage := 'Kein nachfolgender Key gefunden'; + 10245, + 10260 : IsamErrorMessage := 'Kein kleinerer Key gefunden'; + 10255, + 10265 : IsamErrorMessage := 'Sequentieller Zugriff nicht erlaubt'; + 10270 : IsamErrorMessage := 'Keinen passenden ' + + 'Key mit dieser Datensatzreferenz gefunden'; + 10275 : IsamErrorMessage := 'Keine passende Referenz gefunden'; + {!!.42} + 10280, + 10285 : IsamErrorMessage := 'Index leer'; + 10306 : IsamErrorMessage := 'Zu viele Fileblock-Zugriffe'; + 10310 : IsamErrorMessage := 'Netz-Initialisierungs-Fehler'; + 10315 : IsamErrorMessage := 'Netz-Deinitialisierungs-Fehler'; + 10322, + 10323 : IsamErrorMessage := 'Close des Fileblocks wegen nicht ' + + 'entfernbarem Lock fehlgeschlagen'; + 10330 : IsamErrorMessage := 'Fileblock Lock-Versuch gescheitert'; + 10332 : IsamErrorMessage := 'Fileblock Readlock-Versuch gescheitert'; + 10335 : IsamErrorMessage := 'Datensatz Lock-Versuch gescheitert'; + 10337 : IsamErrorMessage := 'Datensatz Lock-Versuch aus ' + + 'Speicherplatzmangel gescheitert'; + 10340.. + 10342 : IsamErrorMessage := 'Fileblock Unlock-Versuch gescheitert'; + 10345 : IsamErrorMessage := 'Datensatz Unlock-Versuch gescheitert'; + 10355, + 10390, {!!.42} + 10397, + 10399 : IsamErrorMessage := 'Ein Lock verhindert die Operation'; + 10360 : IsamErrorMessage := 'Reparatur beim Oeffnen nicht moeglich,' + + 'da Fileblock nicht im alleinigen Zugriff'; {!!.42} + 10398 : IsamErrorMessage := 'Operation erfordert einen Fileblock ' + + 'im Lock-Zustand'; + 10410 : IsamErrorMessage := 'Daten-Datei nicht gefunden'; + 10411 : IsamErrorMessage := 'Puffer wegen zu wenig Heap nicht ' + + 'erstellt'; + 10412 : IsamErrorMessage := 'Datensatz mehr als 64K Bytes'; + 10415 : IsamErrorMessage := 'Datensatz-Anzahl zu hoch'; + 10420, + 10425 : IsamErrorMessage := + 'Relative Position oder Scalierung falsch'; + 10430 : IsamErrorMessage := + 'Reparatur wegen "read only" gescheitert'; + 10435 : IsamErrorMessage := 'Baumseite mehr als 16K'; + 10440 : IsamErrorMessage := + 'Dialogdatei anlegen wegen "read only" gescheitert'; + 10445 : IsamErrorMessage := 'Kein Fileblock vorhanden'; + 10446 : IsamErrorMessage := 'Rekursiver Aufruf der B-Tree Isam'; + 10450 : IsamErrorMessage := 'Initialisierung bereits geschehen'; + 10455 : IsamErrorMessage := + 'Initialisierung noch nicht geschehen'; + 10460 : IsamErrorMessage := 'Reorganisation abgebrochen'; + 10465 : IsamErrorMessage := {!!.41} + 'Daten- und Sicherungsdatei gleichzeitig vorhanden'; + 10470 : IsamErrorMessage := {!!.50} + 'Fehler bei der Schluesselbildung'; + 10475 : IsamErrorMessage := 'Fehler beim Datensatzumbau'; {!!.50} + 10480 : IsamErrorMessage := {!!.42} + 'Netzmodus fuer diesen Fileblock nicht moeglich'; + Else + IsamErrorMessage := ''; + End; + End; + {$ENDIF} + {$IFDEF EnglishMessage} + English : Begin + Case ErrorNr Of + 9500..9899 : Begin + Str ( ErrorNr - 9500 : 0, S ); + IsamErrorMessage := 'DOS error code <' + S + '>'; + End; + 9900 : IsamErrorMessage := 'Invalid path name'; + 9901 : IsamErrorMessage := 'Too many open files'; + 9903 : IsamErrorMessage := 'File not found'; + 9904 : IsamErrorMessage := 'Invalid handle'; + 9908 : IsamErrorMessage := 'Invalid access code'; + 10000 : IsamErrorMessage := + 'Page buffer is smaller than MaxHeight'; + 10001.. + 10009 : IsamErrorMessage := + 'Serious I/O error occurred while in save mode'; + 10010 : IsamErrorMessage := + 'File defect, that can be corrected by reindexing'; + 10020 : IsamErrorMessage := + 'Record length less than 22 or more than 2147483647 bytes'; + 10030, + 10040 : IsamErrorMessage := 'Insufficient memory'; + 10050 : IsamErrorMessage := 'Invalid number of keys specified'; + 10055, + 10125 : IsamErrorMessage := 'Key too long'; + 10060 : IsamErrorMessage := 'Too many keys, or file read error'; + 10065 : IsamErrorMessage := {!!.41} + 'Attempt to write to read only Fileblock'; + 10070 : IsamErrorMessage := 'File read error'; + 10075 : IsamErrorMessage := 'File write error'; + 10080 : IsamErrorMessage := 'Fileblock not open'; + 10090, + 10100, + 10356 : IsamErrorMessage := + 'Insufficient memory to allocate Fileblock'; + 10110 : IsamErrorMessage := 'Drive not ready'; + 10120 : IsamErrorMessage := 'PageSize incompatible with Fileblock'; + 10121 : IsamErrorMessage := 'MaxKeyLen too small'; + 10122 : IsamErrorMessage := 'MaxPageSize too small'; {!!.42} + 10130, + 10135 : IsamErrorMessage := 'Record 0 must not be accessed'; + 10140 : IsamErrorMessage := 'Access not possible, undefined error'; + 10150 : IsamErrorMessage := + 'Insufficient handles for flush of network Fileblock'; + 10160 : IsamErrorMessage := 'Fileblock not correctly closed'; + 10164 : IsamErrorMessage := 'Invalid key number'; + 10170 : IsamErrorMessage := 'Consistency of Fileblock endangered'; + 10180 : IsamErrorMessage := 'Attempt to repair Fileblock failed'; + 10190 : IsamErrorMessage := + 'Extend handle function requires DOS 3.3 or later'; + 10191 : IsamErrorMessage := + 'Insufficient memory for new file handle table'; + 10192 : IsamErrorMessage := + 'Unable to initialize new file handle table'; + 10200 : IsamErrorMessage := 'No matching key found'; + 10205 : IsamErrorMessage := 'Data record is currently locked'; + 10210 : IsamErrorMessage := + 'No key found and no larger keys available'; + 10215 : IsamErrorMessage := {!!.50} + 'Reindex failed, the data file is inconsistent'; {!!.50} + 10220 : IsamErrorMessage := 'Key to delete was not found'; + 10230 : IsamErrorMessage := 'Cannot add duplicate key'; + 10240, + 10250 : IsamErrorMessage := 'No larger key found'; + 10245, + 10260 : IsamErrorMessage := 'No smaller key found'; + 10255, + 10265 : IsamErrorMessage := 'Sequential access not allowed'; + 10270 : IsamErrorMessage := + 'No matching key and record number found'; + 10275 : IsamErrorMessage := 'No matching reference found'; {!!.42} + 10280, + 10285 : IsamErrorMessage := 'Index empty'; + 10306 : IsamErrorMessage := 'Too many Fileblock accesses'; + 10310 : IsamErrorMessage := 'Network initialization error'; + 10315 : IsamErrorMessage := 'Network exit error'; + 10322, + 10323 : IsamErrorMessage := 'Close of Fileblock not possible because' + + ' of a non-removeable lock'; + 10330 : IsamErrorMessage := 'Fileblock lock attempt failed'; + 10332 : IsamErrorMessage := 'Fileblock readlock attempt failed'; + 10335 : IsamErrorMessage := 'Record lock attempt failed'; + 10337 : IsamErrorMessage := 'Record lock attempt failed ' + + 'because of insufficient memory'; + 10340.. + 10342 : IsamErrorMessage := 'Fileblock unlock attempt failed'; + 10345 : IsamErrorMessage := 'Record unlock attempt failed'; + 10355, + 10390, {!!.42} + 10397, + 10399 : IsamErrorMessage := 'A lock prevents the operation'; + 10360 : IsamErrorMessage := 'No repair during open, because the' + + 'Fileblock is not exclusively used'; {!!.42} + 10398 : IsamErrorMessage := 'Fileblock must be locked'; + 10410 : IsamErrorMessage := 'Data file not found'; + 10411 : IsamErrorMessage := + 'Insufficient heap space for work buffers'; + 10412 : IsamErrorMessage := 'Record section length exceeds 64K'; + 10415 : IsamErrorMessage := 'Too much records'; + 10420, + 10425 : IsamErrorMessage := 'Relative position or scale invalid'; + 10430 : IsamErrorMessage := 'No repair in read only mode'; + 10435 : IsamErrorMessage := 'Tree page greater than 16k'; + 10440 : IsamErrorMessage := + 'No creating of dialog file in read only mode'; + 10445 : IsamErrorMessage := 'Invalid Fileblock'; + 10446 : IsamErrorMessage := 'Recursive call of B-Tree Isam'; + 10450 : IsamErrorMessage := 'Initialization already done'; + 10455 : IsamErrorMessage := 'Initialization not yet done'; + 10460 : IsamErrorMessage := 'Reorganization aborted'; + 10465 : IsamErrorMessage := {!!.41} + 'Data and save file exist simultaneously'; + 10470 : IsamErrorMessage := {!!.50} + 'Error while building a key'; + 10475 : IsamErrorMessage := {!!.50} + 'Error while restructing the data record'; + 10480 : IsamErrorMessage := {!!.42} + 'Fileblock cannot be opened in net mode'; + Else + IsamErrorMessage := ''; + End; + End; + {$ENDIF} + Else + IsamErrorMessage := ''; + End; + End; + + +{$IFDEF LengthByteKeys} + Procedure InvertString ( Var Dest : String; + Source : String; + MaxLen : Byte ); + {-Inverts the string Source under a maximum length of MaxLen returning + the result in Dest} + + Var + i : integer; + ToSubLen, + EatCount, + ResLen, + ActInd : Byte; + Cont : Boolean; + + Begin + ToSubLen := Length (Source); + If MaxLen < ToSubLen Then Begin + Dest := ''; + Exit; + End; + FillChar ( Source [Succ (ToSubLen)], MaxLen - ToSubLen, $FF ); + If ToSubLen = 0 Then Begin + Source [0] := Chr (MaxLen); + Dest := Source; + Exit; + End; + {$IFDEF Win32} + for i := 1 to ToSubLen do + Source[i] := char(not ord(Source[i])); + {$ELSE} + {$IFDEF FPC} + for i := 1 to ToSubLen do + Source[i] := char(not ord(Source[i])); + {$ELSE} + Inline ( + $8A / $8E / ToSubLen / {Mov CL, [BP+ToSubLen]} + $30 / $ED / {Xor CH, CH} + $BF / Source + 1 / {Mov DI, Ofs (Source [1])} + $F6 / $13 / {L1: Not [BP+DI]} + $47 / {Inc DI} + $E2 / $FB {Loop L1} + ); + {$ENDIF FPC} + {$ENDIF} + {-Invert string entries up to ToSubLen} + ResLen := MaxLen; + If Ord (Source [MaxLen]) >= ToSubLen Then Begin + Dec (Source [MaxLen], ToSubLen); + End Else Begin + If Ord (Succ (Source [MaxLen])) = ToSubLen Then Begin + ResLen := Pred (MaxLen); + End Else Begin + Inc (Source [MaxLen], 257 - ToSubLen); + EatCount := Ord (Source [MaxLen]); + ActInd := Pred (MaxLen); + Cont := True; + While Cont And (ActInd > 0) Do Begin + If Source [ActInd] > #0 Then Begin + Dec (Source [ActInd]); + Cont := False; + End Else Begin + If EatCount <= 255 Then Begin {!!.52} + Source [ActInd] := #255; + Dec (ActInd); + Inc (EatCount); + End Else Begin + ResLen := Pred (ActInd); + Cont := False; + End; + End; + End; + If ActInd = 0 Then ResLen := 0; + End; + End; + Source [0] := Chr (ResLen); + Dest := Source; + End; +{$ENDIF} + + +{$IFDEF ASCIIZeroKeys} + Procedure InvertString ( Var Dest; + Var Source; + MaxLen : Byte ); + {-Inverts the null terminated array of character Source under a + maximum length of MaxLen returning the result in Dest} + Var + DestStr : Array [Byte] Of Byte Absolute Dest; + SourceStr : Array [Byte] Of Byte Absolute Source; + ToSubLen, + EatCount, + ResLen : Byte; + ActInd : Integer; + Cont : Boolean; + + + Function AZStrLen ( StrPtr : Pointer ) : Word; + {-Returns the length of the ASCII zero string} + {$IFDEF FPC} + var + P : PByte; + begin + P := StrPtr; + AZStrLen := 0; + while P^ <> 0 do begin + Inc(AZStrLen); + Inc(P); + end; + end; + {$ELSE} + {$IFDEF Win32} + register; + asm + push edi + mov edi, eax + xor eax, eax + mov ecx, $FFFF + repne scasb + mov eax, $FFFE + sub eax, ecx + pop edi + end; + {$ELSE} + Begin + Inline ( + $FC / {Cld} + $C4 / $7E / < StrPtr / {Les, DI [BP+StrPtr]} + $B9 / $FF / $FF / {Mov CX, $FFFF} + $30 / $C0 / {Xor AL, AL} + $F2 / $AE / {Repnz Scasb} + $B8 / $FE / $FF / {Mov AX, $FFFE} + $29 / $C8 {Sub AX, CX} + ); + End; + {$ENDIF} + {$ENDIF FPC} + + + Procedure SubFrom256 ( StrPtr : Pointer; Len : Byte ); + {-Subtracts Len Bytes at StrPtr from 256 and stores the result there} + {$IFDEF FPC} + var + P : PByte; + I : Byte; + begin + P := StrPtr; + for I := 1 to Len do begin + P^ := not P^; + Inc(P); + end; + end; + {$ELSE} + {$IFDEF Win32} + register; + asm + movzx ecx, dl + @@Again: + not [eax] + inc eax + dec ecx + jnz @@Again + end; + {$ELSE} + Begin + Inline ( + $C4 / $7E / < StrPtr / {Les, DI [BP+StrPtr]} + $8A / $8E / Len / {Mov CL, [BP+Len]} + $30 / $ED / {Xor CH, CH} + $26 / $F6 / $1D / {L1: Neg [ES:DI]} + $47 / {Inc DI} + $E2 / $FA {Loop L1} + ); + End; + {$ENDIF} + {$ENDIF FPC} + + + Begin + ToSubLen := AZStrLen ( @SourceStr ); + If MaxLen < ToSubLen Then Begin + DestStr [0] := 0; + Exit; + End; + Move ( SourceStr, DestStr, ToSubLen ); + FillChar ( DestStr [ToSubLen], MaxLen - ToSubLen, $FF ); + DestStr [MaxLen] := 0; + + If ToSubLen = 0 Then Exit; + SubFrom256 ( @DestStr, ToSubLen ); + + ResLen := MaxLen; + If DestStr [Pred (MaxLen)] > ToSubLen Then Begin + Dec (DestStr [Pred (MaxLen)], ToSubLen); + End Else Begin + If DestStr [Pred (MaxLen)] = ToSubLen Then Begin + ResLen := Pred (MaxLen); + End Else Begin + Inc (DestStr [Pred (MaxLen)], 256 - ToSubLen); + EatCount := DestStr [Pred (MaxLen)]; + ActInd := MaxLen - 2; + Cont := True; + While Cont And (ActInd >= 0) Do Begin + If DestStr [ActInd] > 1 Then Begin + Dec (DestStr [ActInd]); + Cont := False; + End Else Begin + If EatCount <= 255 Then Begin {!!.52} + DestStr [ActInd] := 255; + Dec (ActInd); + Inc (EatCount); + End Else Begin + ResLen := ActInd; + Cont := False; + End; + End; + End; + If ActInd = -1 Then ResLen := 0; + End; + End; + DestStr [ResLen] := 0; + End; +{$ENDIF} + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/isamwork.inc b/src/wc_sdk/isamwork.inc new file mode 100644 index 0000000..421f544 --- /dev/null +++ b/src/wc_sdk/isamwork.inc @@ -0,0 +1,2004 @@ +{********************************************************************} +{* ISAMWORK.INC *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{$IFDEF LengthByteKeys} +procedure IsamMakeStrZ(var UserKey, UserKeyZ : IsamKeyStr); +begin + Move(UserKey, UserKeyZ, Succ(Word(Length(UserKey)))); +end; + + +procedure IsamMakeStr(var UserKeyZ, UserKey : IsamKeyStr); +begin + Move(UserKeyZ, UserKey, Succ(Word(Length(UserKeyZ)))); +end; +{$ENDIF} + +{$IFDEF ASCIIZeroKeys} +procedure IsamMakeStrZ(var UserKey, UserKeyZ : IsamKeyStr); +var + L : Word; +begin + L := Length (UserKey); + if L > MaxKeyLen then + L := MaxKeyLen; + Move(UserKey [1], UserKeyZ, L); + UserKeyZ [L] := #0; +end; + + +procedure IsamMakeStr(var UserKeyZ, UserKey : IsamKeyStr); +var + L : Word; +begin + L := 0; + while UserKeyZ [L] <> #0 do begin + Inc (L); + end; + if L <> 0 then begin + Move(UserKeyZ, UserKey [1], L); + end; + UserKey [0] := Chr (L); +end; +{$ENDIF} + +procedure IsamPack(var Page : IsamPage; KeyL : Word); +var + I, K, S : Word; + P : Array [0..0] Of Byte absolute Page; {Real bounds [0..65535]} +begin + K := KeyL + 9; + S := K + 6; + if KeyL <> MaxKeyLen then begin + for I := 2 to Page.ItemsOnPage do begin + Move(Page.ItemArray[I], P[S], K); + Inc(S, K); + end; + end; +end; + + +procedure IsamUnPack(var Page : IsamPage; KeyL : Word); +var + I, K, S : Word; + P : Array [0..0] Of Byte absolute Page; {Real bounds [0..65535]} +begin + K := KeyL + 9; + S := Pred (Page.ItemsOnPage) * K + 6; + if KeyL <> MaxKeyLen then begin + for I := Page.ItemsOnPage downto 2 do begin + Move(P[S], Page.ItemArray[I], K); + S := S - K; + end; + end; +end; + + +function IsamFirstFreeChanged(IFBPtr : IsamFileBlockPtr; + Ind : Word ) : Boolean; +begin + IsamFirstFreeChanged := IFBPtr^.DIDPtr^[Ind]^.FirstFreeChanged; +end; + + +procedure IsamGetInfoRec(IFBPtr : IsamFileBlockPtr; + KeyNr : Word; + var IndFopen : Boolean); +var + IR : IsamInfoRec; +begin + IsamClearOK; + with IFBPtr^, DIDPtr^[KeyNr]^, IR, InfoRec do begin + if KeyNr = 0 then begin + IsamGetBlock(DatF, 0, SizeOf (IsamSmallInfoRec), IR); + end + else begin + IsamGetBlock(IndF, BlockOfs, SizeOf (IsamInfoRec), IR); + end; + if not IsamOK then Exit; + FirstFree := Gener [1]; + NumberFree := Gener [2]; + NumRec := Gener [3]; + LenRec := Gener [4]; + if KeyNr = 0 then begin + NrOfKeys := ILI (Gener [5]).Lo; + IndFopen := ADK; + end + else begin + RootRef := Gener [5]; + AllowDupKeys := ADK; + NumKeys := KeysUsed; + UsedPageSize := PageSizeUsed; {!!.42} + if UsedPageSize = 0 then {!!.42} + UsedPageSize := CreatePageSize; {!!.42} + end; + end; +end; + + +procedure IsamCopyInfoRecToIR(IFBPtr : IsamFileBlockPtr; + KeyNr : Word; + var IR : IsamInfoRec); +begin + with IFBPtr^, DIDPtr^[KeyNr]^, IR, InfoRec do begin + Gener[1] := FirstFree; + Gener[2] := NumberFree; + Gener[3] := NumRec; + Gener[4] := LenRec; + if KeyNr = 0 then begin + Gener[5] := NrOfKeys; + ADK := False; + end + else begin + Gener[5] := RootRef; + ADK := AllowDupKeys; + KeysUsed := NumKeys; + PageSizeUsed := UsedPageSize; {!!.42} + end; + end; +end; + + +procedure IsamPutInfoRec(IFBPtr : IsamFileBlockPtr; + KeyNr : Word; + IndFDamaged : Boolean); +var + IR : IsamInfoRec; +begin + IsamClearOK; + with IFBPtr^, DIDPtr^[KeyNr]^ do begin + IsamCopyInfoRecToIR(IFBPtr, KeyNr, IR); + if KeyNr = 0 then begin + IR.InfoRec.ADK := IndFDamaged; + IsamPutBlock(DatF, 0, SizeOf (IsamSmallInfoRec), IR); + end + else begin + IsamPutBlock(IndF, BlockOfs, SizeOf (IsamInfoRec), IR); + end; + end; +end; + + +procedure IsamSaveGivenInfoRec(IFBPtr : IsamFileBlockPtr; + Ind : Word; + IR : IsamInfoRec; + SaveFirstFree : LongInt); +var + Buffer : IsamSaveInfoRecBuffer; +begin + with IFBPtr^, Buffer do begin + IST := 1000; {Sign for info rec} + IndNr := Ind; + BIR := IR; + SFF := SaveFirstFree; + IsamBlockWrite(DiaF, Buffer, SizeOf (Buffer)); + end; +end; + + +function IsamRBufPtrToPgPtr(RBufPtr : IsamRingBufferRecPtr) : IsamPagePtr; + {-Map of page will and can already be done} +begin +{$IFDEF UseEMSHeap} + with RBufPtr^ do begin + if EMSEntry then begin + if EMSHeapIsUsed then begin + if UserSaveEMSHandle = 0 then begin + UserSaveEMSHandle := SaveEMSCtxt; + {$IFDEF EMSDisturbance} + RestoreEMSCtxt(OwnSaveEMSHandle); + {$ENDIF} + end; + end; + IsamRBufPtrToPgPtr := MapEMSPtr(RBufPtr^.PageEntryPtr); + end + else begin + IsamRBufPtrToPgPtr := IsamPagePtr(RBufPtr^.PageEntryPtr); + end; + end; +{$else} + IsamRBufPtrToPgPtr := IsamPagePtr(RBufPtr^.PageEntryPtr); +{$ENDIF} +end; + + +function IsamPagePtrToRBufPtr(PgPtr : IsamPagePtr) : IsamRingBufferRecPtr; + {-Map of page must already be done} +begin + IsamPagePtrToRBufPtr := IsamPageEntryPtr (PgPtr)^.RingBufferPtr; +end; + + +procedure IsamSavePage(var Pg : IsamPage); +var + IRBPtr : IsamRingBufferRecPtr; + IPEPtr : IsamPageEntryPtr; + P : Array [0..4] Of Byte Absolute Pg; {May reference 0..65535} + K : Word; + TempLI : LongInt; +begin + IRBPtr := IsamPagePtrToRBufPtr(Addr (Pg)); + IPEPtr := Addr (Pg); + {-Map must be already done, so another map is not necessary} + with IRBPtr^, IFBlPtr^, IPEPtr^, Page do begin + IsamPack(Page, DIDPtr^[KeyNr]^.KeyLen); + TempLI := BckwPageRef; + + {--Calculate length of packed page} + K := ItemsOnPage *(DIDPtr^[KeyNr]^.KeyLen + 9) + 6; + Move(KeyNr, P [2], 2); {over BckwPageRef} + + {--Write beyond the end of the packed page (2x)} + Move(PageRef, P [K], 4); + Move(TempLI, P [K + 4], 4); {BckwPageRef at end} + IsamBlockWrite(IFBlPtr^.DiaF, Pg, K + 8); + + BckwPageRef := TempLI; + IsamUnPack(Page, DIDPtr^[KeyNr]^.KeyLen); + SaveBuffered := True; + end; +end; + + +procedure IsamOnlyFlushDOSDat(IFBPtr : IsamFileBlockPtr); +var + Dummy : Boolean; +begin + IsamFlush(IFBPtr^.DatF, Dummy, + (IFBPtr^.NSP <> Nil) and (IsamInitializedNet <> NoNet)); +end; + + +procedure IsamFlushDOSDat(IFBPtr : IsamFileBlockPtr); +begin + with IFBPtr^ do begin + if DIDPtr^[0]^.InfoRecChanged or not SaveFB then begin + DIDPtr^[0]^.InfoRecChanged := False; + DIDPtr^[0]^.IRChangedSaveN := True; + IsamPutInfoRec(IFBPtr, 0, False); + if not IsamOK then Exit; + end; + end; + IsamOnlyFlushDOSDat(IFBPtr); +end; + + +procedure IsamFlushDOSIx(IFBPtr : IsamFileBlockPtr); +var + Dummy : Boolean; +begin + IsamFlush(IFBPtr^.IndF, Dummy, + (IFBPtr^.NSP <> Nil) and (IsamInitializedNet <> NoNet)); +end; + + +procedure IsamFlushDOSDia(IFBPtr : IsamFileBlockPtr; Continue : Boolean); +var + WithDUP : Boolean; + Dummy : DWORD; {!!.54} +begin + with IFBPtr^ do begin + IsamFlush(DiaF, WithDUP, + (NSP <> Nil) and (IsamInitializedNet <> NoNet)); + if not IsamOK then Exit; + if Continue and not WithDUP then + IsamLongSeekEOF(DiaF, Dummy); + end; +end; + + +procedure IsamMakeDiaFile(var F : IsamFile); +var + Dummy : Char; +begin + IsamRewrite(F); + if not IsamOK then Exit; + IsamBlockWrite(F, Dummy, 1); +end; + + +procedure IsamReduceDiaFile(IFBPtr : IsamFileBlockPtr); +var + Dummy : Char; +begin + IsamPutBlock(IFBPtr^.DiaF, 1, 0, Dummy); + if not IsamOK then Exit; + if(IFBPtr^.NSP = Nil) or IsamNetEmu then begin + IsamFlushDOSDia(IFBPtr, True); + end; +end; + + +procedure IsamSetDataBufferedFlag(IFBPtr : IsamFileBlockPtr); +begin + with IFBPtr^ do begin + if DataBuffered then Exit; + DataBuffered := True; + if SaveFB then Exit; + IsamPutBlock(DatF, 20, 1, DataBuffered); + if IsamForceFlushOfMark and (IsamNetEmu or (NSP = Nil)) then begin + IsamOnlyFlushDOSDat(IFBPtr); + end; + end; +end; + + +function IsamGetNextUsedAddRecRef(IFBPtr : IsamFileBlockPtr) : LongInt; +begin + IsamGetNextUsedAddRecRef := 0; + with IFBPtr^, DIDPtr^[0]^ do begin + if FirstFree <> -1 then begin + if (FirstFree <= 0) or (FirstFree > NumRec) then begin + IsamError := 10170; + IsamOK := False; + Exit; + end; + IsamGetNextUsedAddRecRef := FirstFree; + end + else begin + IsamGetNextUsedAddRecRef := Succ (NumRec); + end; + end; +end; + + +function IsamGetAfterNextUsedAddRecRef(IFBPtr : IsamFileBlockPtr) + : LongInt; +var + NextFree : LongInt; +begin + IsamGetAfterNextUsedAddRecRef := 0; + with IFBPtr^, DIDPtr^[0]^ do begin + if FirstFree <> -1 then begin + NextFree := FirstFree; + if (NextFree <= 0) or (NextFree > NumRec) then begin + IsamError := 10170; + IsamOK := False; + Exit; + end; + IsamGetBlock(DatF, NextFree * LenRec, SizeOf (LongInt), NextFree); + if not IsamOK then Exit; + if (NextFree = 0) or + (NextFree > NumRec) or + (NextFree < -1) then begin + IsamError := 10170; + IsamOK := False; + Exit; + end; + if NextFree <> -1 then begin + IsamGetAfterNextUsedAddRecRef := NextFree; + end + else begin + IsamGetAfterNextUsedAddRecRef := Succ (NumRec); + end; + end + else begin + IsamGetAfterNextUsedAddRecRef := NumRec + 2; + end; + end; +end; + + +procedure IsamNewRec(IFBPtr : IsamFileBlockPtr; + var RefNr : LongInt; + Ind : Word); +var + NextFree : LongInt; +begin + with IFBPtr^, DIDPtr^[Ind]^ do begin + InfoRecChanged := True; + if FirstFree <> -1 then begin + if (FirstFree <= 0) or (FirstFree > NumRec) then begin + IsamError := 10170; + IsamOK := False; + Exit; + end; + RefNr := FirstFree; + if Ind = 0 then begin + IsamGetBlock(DatF, RefNr * LenRec, SizeOf (LongInt), NextFree); + end + else begin + IsamGetBlock(IndF, RefNr * BlockLen + BlockOfs, SizeOf (LongInt), + NextFree); + end; + if not IsamOK then Exit; + if (NextFree = 0) or (NextFree > NumRec) or (NextFree < -1) then begin + IsamError := 10170; + IsamOK := False; + Exit; + end; + FirstFree := NextFree; + FirstFreeChanged := True; + Dec (NumberFree); + end + else begin + FirstFreeChanged := False; + Inc (NumRec); + RefNr := NumRec; + if (Ind <> 0) and (NumRec > MaxPages) then begin + IsamPutDummyBlock(IndF, Succ (MaxPages) * BlockLen, BlockLen); + if not IsamOK then begin + Dec (NumRec); + Exit; + end; + Inc (MaxPages); + end; + end; + end; +end; + + +procedure IsamDeleteRecOrPage(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Ind : Word); +begin + with IFBPtr^, DIDPtr^[Ind]^ do begin + InfoRecChanged := True; + if Ind = 0 then begin + IsamPutBlock(DatF, RefNr * LenRec, SizeOf (LongInt), FirstFree); + end + else begin + IsamPutBlock(IndF, RefNr * BlockLen + BlockOfs, SizeOf (LongInt), + FirstFree); + end; + if not IsamOK then Exit; + FirstFree := RefNr; + Inc (NumberFree); + end; +end; + + +{$IFNDEF Windows} +{$IFNDEF Win32} +function IsamAvailable(Mem : LongInt) : Boolean; +begin +{$IFDEF FPC} + IsamAvailable := True; { FPC has flat memory model, assume available } +{$ELSE} + IsamAvailable := MaxAvail >= Mem; +{$ENDIF} +end; +{$ENDIF} +{$ENDIF} + + +procedure IsamAddToOpenFileBlockList(IFBPtr : IsamFileBlockPtr); + {!!.52 rearranged} +var + T1Ptr, + T2Ptr : IsamOpenFileBlockListPtr; +begin + IsamClearOK; + if not IsamGetMem(T1Ptr, sizeof(IsamOpenFileBlockList)) then begin {!!.52} + IsamOK := False; + IsamError := 10100; + Exit; + end; + if IsamOFBLPtr <> Nil then begin + T2Ptr := IsamOFBLPtr; + while T2Ptr^.Next <> Nil do begin + T2Ptr := T2Ptr^.Next; + end; + T2Ptr^.Next := T1Ptr; + end + else begin + IsamOFBLPtr := T1Ptr; + end; + T1Ptr^.Next := Nil; + T1Ptr^.OIFBPtr := IFBPtr; +end; + + +procedure IsamRemoveFromOpenFileBlockList(IFBPtr : IsamFileBlockPtr); +var + T1Ptr, + T2Ptr : IsamOpenFileBlockListPtr; + Found : Boolean; +begin + IsamClearOK; + T1Ptr := IsamOFBLPtr; + if T1Ptr = Nil then Exit; + if T1Ptr^.OIFBPtr = IFBPtr then begin + IsamOFBLPtr := T1Ptr^.Next; + end + else begin + T2Ptr := T1Ptr; + T1Ptr := T1Ptr^.Next; + Found := False; + while (T1Ptr <> Nil) and not Found do begin + Found := T1Ptr^.OIFBPtr = IFBPtr; + if not Found then begin + T2Ptr := T1Ptr; + T1Ptr := T1Ptr^.Next; + end; + end; + if not Found then Exit; + T2Ptr^.Next := T1Ptr^.Next; + end; + FreeMem(T1Ptr, SizeOf (IsamOpenFileBlockList)); +end; + + +function IsamFileBlockIsInOpenList(IFBPtr : IsamFileBlockPtr) : Boolean; +var + TPtr : IsamOpenFileBlockListPtr; +begin + IsamFileBlockIsInOpenList := True; + TPtr := IsamOFBLPtr; + while TPtr <> Nil do begin + if TPtr^.OIFBPtr = IFBPtr then Exit; + TPtr := TPtr^.Next; + end; + IsamFileBlockIsInOpenList := False; +end; + + +procedure IsamFreeKeyDescrMem(IFBPtr : IsamFileBlockPtr; Nr : Integer); +var + I : Integer; +begin + with IFBPtr^ do begin + for I := Nr downto 0 do begin + FreeMem(DIDPtr^[I], SizeOf (IsamDatIndDescr)); + end; + FreeMem(DIDPtr, SizeOf (IsamDatIndDescrPtr) * Succ (NrOfKeys)); + end; +end; + + +procedure IsamGetKeyDescrMem(IFBPtr : IsamFileBlockPtr; Nr : Integer); + {!!.52 rewritten} + {----} + procedure Undo(IFBPtr : IsamFileBlockPtr; Nr : Integer); + var + i : Integer; + begin + with IFBPtr^ do + for i := Nr downto 0 do + FreeMem(DIDPtr^[i], sizeof(IsamDatIndDescr)); + end; + {----} + var + i : Integer; + begin + IsamOK := False; + IsamError := 10030; + if not IsamGetMem(IFBPtr^.DIDPtr, sizeof(IsamDatIndDescrPtr) * succ(Nr)) then + Exit; + for i := 0 to Nr do + if not IsamGetMem(IFBPtr^.DIDPtr^[i], sizeof(IsamDatIndDescr)) then begin + Undo(IFBPtr, pred(i)); + FreeMem(IFBPtr^.DIDPtr, sizeof(IsamDatIndDescrPtr) * succ(Nr)); + Exit; + end; + IsamClearOK; + end; + + +procedure IsamLast(IRBRPtr : IsamRingBufferRecPtr); {!!.42mod} +begin + if IRBRPtr <> IsamRBR1Ptr^.Prev then begin + if IRBRPtr = IsamRBR1Ptr then begin + IsamRBR1Ptr := IsamRBR1Ptr^.Next + end + else begin + IRBRPtr^.Prev^.Next := IRBRPtr^.Next; + IRBRPtr^.Next^.Prev := IRBRPtr^.Prev; + IRBRPtr^.Next := IsamRBR1Ptr; + IRBRPtr^.Prev := IsamRBR1Ptr^.Prev; + IsamRBR1Ptr^.Prev^.Next := IRBRPtr; + IsamRBR1Ptr^.Prev := IRBRPtr; + end; + end; +end; + + +procedure IsamOptimizePageBuffer; +var + TPtr, + TBPtr : IsamRingBufferRecPtr; + W : Word; +begin + TPtr := IsamRBR1Ptr; + for W := 1 to IsamNrOfRingBufferRecs do begin + TBPtr := TPtr^.Next; + if TPtr^.IFBlPtr <> Nil then + IsamLast(TPtr); + TPtr := TBPtr; + end; +end; + + +procedure IsamResetSaveBuffered; +var + TPtr : IsamRingBufferRecPtr; +begin + TPtr := IsamRBR1Ptr; + repeat + with TPtr^ do begin + SaveBuffered := False; + TPtr := Next; + end; + until TPtr = IsamRBR1Ptr; +end; + + +procedure IsamPutPage(IPgPtr : IsamPagePtr; + Destructive : Boolean); +begin + with IsamPageEntryPtr (IPgPtr)^, RingBufferPtr^, IFBlPtr^, DIDPtr^[KeyNr]^ do begin + if SaveFB then begin + if ((NSP = Nil) or IsamNetEmu) and SaveBuffered then begin + IsamFlushDOSDia(IFBlPtr , True); + if not IsamOK then Exit; + IsamResetSaveBuffered; + end; + end; + UpDated := False; + IsamPack(Page, KeyLen); + IsamPutBlock(IndF, PageRef * BlockLen + BlockOfs, + LongInt (6) + LongInt (KeyLen + 9) * LongInt (Page.ItemsOnPage), + Page); + if not Destructive then + IsamUnPack(Page, KeyLen); + end; +end; + + +procedure IsamGetPage( IFBPtr : IsamFileBlockPtr; + PRef : LongInt; + Key : Word; + var IPgPtr : IsamPagePtr); +var + TPtr : IsamRingBufferRecPtr; + Found : Boolean; +begin + TPtr := IsamRBR1Ptr; + Found := False; + repeat + TPtr := TPtr^.Prev; + with TPtr^ do begin + if PageRef = PRef then begin + if KeyNr = Key then begin + if IFBlPtr = IFBPtr then begin + Found := True; + IPgPtr := IsamRBufPtrToPgPtr(TPtr); + end; + end; + end; + end; + until Found or (TPtr = IsamRBR1Ptr); + if not Found then begin + TPtr := IsamRBR1Ptr; + IPgPtr := IsamRBufPtrToPgPtr(TPtr); + with TPtr^ do begin + if UpDated then begin + IsamPutPage(IPgPtr, True); + if not IsamOK then Exit; + end; + with IFBPtr^, DIDPtr^[Key]^ do begin + IsamGetBlock(IndF, PRef * BlockLen + BlockOfs, LenRec, IPgPtr^); + if not IsamOK then Exit; + IsamUnPack(IPgPtr^, KeyLen); + IFBlPtr := IFBPtr; + PageRef := PRef; + UpDated := False; + KeyNr := Key; + end; + end; + end; + IsamLast(TPtr); +end; + + +procedure IsamNewPage( IFBPtr : IsamFileBlockPtr; + var PRef : LongInt; + var IPgPtr : IsamPagePtr; + Key : Word); +begin + IsamClearOK; + IPgPtr := IsamRBufPtrToPgPtr(IsamRBR1Ptr); + with IsamRBR1Ptr^ do begin + if UpDated then begin + IsamPutPage(IPgPtr, True); + if not IsamOK then Exit; + end; + IsamNewRec(IFBPtr, PRef, Key); + IFBlPtr := IFBPtr; + PageRef := PRef; + KeyNr := Key; + UpDated := False; + end; + IsamLast(IsamRBR1Ptr); +end; + + +procedure IsamUpdatePage(PgPtr : IsamPagePtr); +begin + IsamPagePtrToRBufPtr(PgPtr)^.UpDated := True; +end; + + +procedure IsamReturnPage(var PgPtr : IsamPagePtr); +begin + with IsamPagePtrToRBufPtr(PgPtr)^ do begin + IsamDeleteRecOrPage(IFBlPtr, PageRef, KeyNr); + IFBlPtr := Nil; + UpDated := False; + IsamOptimizePageBuffer; + end; +end; + + +{$IFDEF LengthByteKeys} +function IsamCompKeys(var Key1, Key2 : IsamKeyStr; + DatRef1, + DatRef2 : LongInt; + Dup : Boolean ) : Integer; + {$IFDEF FPC} + function CompareStrings(const S1, S2 : IsamKeyStr) : Integer; + var + Len, I : Integer; + begin + Len := Length(S1); + if Length(S2) < Len then Len := Length(S2); + for I := 1 to Len do begin + if Byte(S1[I]) < Byte(S2[I]) then begin CompareStrings := -1; Exit; end; + if Byte(S1[I]) > Byte(S2[I]) then begin CompareStrings := 1; Exit; end; + end; + if Length(S1) < Length(S2) then CompareStrings := -1 + else if Length(S1) > Length(S2) then CompareStrings := 1 + else CompareStrings := 0; + end; + {----} +var + CmpResult : Integer; +begin + CmpResult := CompareStrings(Key1, Key2); + if (CmpResult = 0) and Dup then begin + if DatRef1 < DatRef2 then CmpResult := -1 + else if DatRef1 > DatRef2 then CmpResult := 1 + else CmpResult := 0; + end; + IsamCompKeys := CmpResult; +end; +{$ELSE} + {$IFDEF Win32} + function CompareStrings(const S1, S2 : IsamKeyStr) : integer; register; + asm + push edi + push esi + mov edi, edx + mov esi, eax + xor eax, eax + mov dh, [edi] + mov dl, [esi] + inc edi + inc esi + xor ecx, ecx + mov cl, dl + cmp cl, dh + jb @@CompStrs + mov cl, dh + @@CompStrs: + or ecx, ecx + jz @@CompLengths + repe cmpsb + jb @@LT + ja @@GT + @@CompLengths: + cmp dl, dh + je @@Exit + jb @@LT + @@GT: + inc eax + inc eax + @@LT: + dec eax + @@Exit: + pop esi + pop edi + end; + {----} +begin + Result := CompareStrings(Key1, Key2); + if (Result = 0) and Dup then + Result := DatRef1 - DatRef2; +end; +{$else} + {------} + function Sgn(X : LongInt) : Integer; + begin + if X = LongInt (0) then begin + Sgn := 0; + end + else begin + if X < 0 then begin + Sgn := -1; + end + else begin + Sgn := 1; + end; + end; + end; + {------} +var + C, + Len : Integer; +begin + Len := Length (Key1); + if Length (Key2) < Len then + Len := Length (Key2); + Inline ( + $8C / $DA / { Mov DX, DS } + $C4 / $BE / Key1 / { Les DI, Key1 [BP] } + $C5 / $B6 / Key2 / { Lds SI, Key2 [BP] } + $47 / { Inc DI } + $46 / { Inc SI } + $8B / $8E / Len / { Mov CX, [BP+Ofs(Len)] } + $FC / { Cld } + $31 / $C0 / { Xor AX, AX } + $F3 / { Repz } + $A6 / { Cmpsb } + $74 / $05 / { Jz OK } + $40 / { Inc AX } + $72 / $02 / { Jc OK } + $F7 / $D8 / { Neg AX } + { OK: } $8E / $DA / { Mov DS, DX } + $89 / $86 / C { Mov [BP+Ofs(C)], AX } + ); + IsamCompKeys := C; + if C <> 0 then Exit; + if Length (Key1) = Length (Key2) then begin + if Dup then begin + IsamCompKeys := Sgn(DatRef1 - DatRef2); + end; + end + else begin + if Length (Key1) > Length (Key2) then begin + IsamCompKeys := 1; + end + else begin + IsamCompKeys := -1; + end; + end; +end; +{$ENDIF} +{$ENDIF FPC} +{$ENDIF} + +{$IFDEF ASCIIZeroKeys} +function IsamCompKeys(var Key1, Key2 : IsamKeyStr; + DatRef1, + DatRef2 : LongInt; + Dup : Boolean ) : Integer; +{$IFDEF Win32} +var {!!.55} + K1 : array [0..MaxKeyLen] of char absolute Key1; {!!.55} + K2 : array [0..MaxKeyLen] of char absolute Key2; {!!.55} +begin + Result := StrComp(K1, K2); {!!.55} + if (Result = 0) and Dup then + Result := DatRef1 - DatRef2; +end; +{$else} + function Sgn(X : LongInt) : Integer; + begin + if X = LongInt (0) then begin + Sgn := 0; + end + else begin + if X < LongInt (0) then begin + Sgn := -1; + end + else begin + Sgn := 1; + end; + end; + end; +var + C : Integer; +begin + Inline ( + $C4 / $BE / Key1 / { Les DI, Key1 [BP] } + $B9 / >MaxKeyLen / { Mov CX, MaxKeyLen } + $41 / { Inc CX } + $89 / $FB / { Mov BX, DI } + $FC / { Cld } + $31 / $C0 / { Xor AX, AX } + $F2 / { Repnz } + $AE / { Scasb } + $29 / $DF / { Sub DI, BX } + $4F / { Dec DI } + $89 / $FB / { Mov BX, DI } + $89 / $D9 / { Mov CX, BX } + $8C / $DA / { Mov DX, DS } + $C4 / $BE / Key1 / { Les DI, Key1 [BP] } + $C5 / $B6 / Key2 / { Lds SI, Key2 [BP] } + $8A / $18 / { Mov BL, [SI+BX] } + $30 / $FF / { Xor BH, BH } + $F3 / { Repz } + $A6 / { Cmpsb } + $75 / $07 / { Jnz Cont } + $39 / $D8 / { Cmp AX, BX } + $74 / $08 / { Jz OK } + $48 / { Dec AX } + $EB / $05 / { Jmp OK } + { Cont: } $40 / { Inc AX } + $72 / $02 / { Jc OK } + $F7 / $D8 / { Neg AX } + { OK: } $8E / $DA / { Mov DS, DX } + $89 / $86 / C { Mov [BP+Ofs(C)], AX } + ); + IsamCompKeys := C; + if (C = 0) and Dup then begin + IsamCompKeys := Sgn(DatRef1 - DatRef2); + end; +end; +{$ENDIF} +{$ENDIF} + +procedure IsamFlushPageBuffer(IFBPtr : IsamFileBlockPtr; + Destructive : Boolean); +var + TPtr : IsamRingBufferRecPtr; +begin + IsamClearOK; + TPtr := IsamRBR1Ptr; + repeat + with TPtr^ do begin + if IFBlPtr = IFBPtr then begin + with IFBPtr^ do begin + if UpDated then begin + IsamPutPage(IsamRBufPtrToPgPtr(TPtr), Destructive); + if not IsamOK then Exit; + end; + end; + if Destructive then + IFBlPtr := Nil; + end; + end; + TPtr := TPtr^.Next; + until TPtr = IsamRBR1Ptr; + if Destructive then + IsamOptimizePageBuffer; +end; + + +procedure IsamFlushPageInfo(IFBPtr : IsamFileBlockPtr; + Destructive : Boolean); +var + I : Integer; +begin + with IFBPtr^ do begin + IsamFlushPageBuffer(IFBPtr, Destructive); + if not IsamOK then Exit; + for I := 1 to NrOfKeys do begin + with DIDPtr^[I]^ do begin + if InfoRecChanged then begin + InfoRecChanged := False; + IRChangedSaveN := True; + IsamPutInfoRec(IFBPtr, I, False); + if not IsamOK then Exit; + end; + end; + end; + end; +end; + + +procedure IsamDestroyPages(IFBPtr : IsamFileBlockPtr); +var + TPtr : IsamRingBufferRecPtr; +begin + TPtr := IsamRBR1Ptr; + repeat + with TPtr^ do begin + if IFBlPtr = IFBPtr then begin + SaveBuffered := False; + UpDated := False; + IFBlPtr := Nil; + end; + end; + TPtr := TPtr^.Next; + until TPtr = IsamRBR1Ptr; +end; + + +procedure IsamDestroyPagesOfKeyNr(IFBPtr : IsamFileBlockPtr; + Key : Word); +var + TPtr : IsamRingBufferRecPtr; +begin + TPtr := IsamRBR1Ptr; + repeat + with TPtr^ do begin + if IFBlPtr = IFBPtr then begin + if KeyNr = Key then begin + SaveBuffered := False; + UpDated := False; + IFBlPtr := Nil; + end; + end; + end; + TPtr := TPtr^.Next; + until TPtr = IsamRBR1Ptr; +end; + + +procedure IsamRepairFileBlock(IFBPtr : IsamFileBlockPtr); +const + RepError = 10180; +var + FrameAlreadySaved : boolean; + {------} + procedure Repair; + var + IST : Word; + {----} + procedure RestoreInfoRec; + var + Buffer : IsamSaveInfoRecBuffer; + begin + IsamBlockRead(IFBPtr^.DiaF, Buffer.IndNr, SizeOf (Buffer) - SizeOf (Word)); + if not IsamOK then Exit; + with Buffer, BIR, InfoRec, IFBPtr^, DIDPtr^[IndNr]^ do begin + if SFF <> -2 then begin + FirstFree := SFF; + IsamDeleteRecOrPage(IFBPtr, Gener [1], IndNr); + if not IsamOK then Exit; + end; + FirstFree := Gener [1]; + NumberFree := Gener [2]; + NumRec := Gener [3]; + LenRec := Gener [4]; + if IndNr = 0 then begin + NrOfKeys := ILI (Gener [5]).Lo; + end + else begin + RootRef := Gener [5]; + AllowDupKeys := ADK; + NumKeys := KeysUsed; + end; + IsamPutInfoRec(IFBPtr, IndNr, False); + InfoRecChanged := False; + end; + end; + {----} + procedure RestorePage; + type + P = Array [0..4] Of Byte; {May reference [0..65535]} + var + PEPtr : IsamPageEntryPtr; + IPgPtr : IsamPagePtr; + K : Word; + PPtr : ^P; + begin + IPgPtr := IsamRBufPtrToPgPtr(IsamRBR1Ptr); + PEPtr := IsamPageEntryPtr (IPgPtr); + PPtr := Addr (PEPtr^); + with IsamRBR1Ptr^, PEPtr^ do begin + if UpDated then begin + IsamPutPage(IPgPtr, True); + if not IsamOK then Exit; + end; + IFBlPtr := Nil; + IsamBlockRead(IFBPtr^.DiaF, PPtr^ [2], 2); + if not IsamOK then Exit; + Move(PPtr^ [2], KeyNr, 2); {Extract KeyNr} + Page.ItemsOnPage := IST; {Extract ItemsOnPage} + K := Page.ItemsOnPage *(IFBPtr^.DIDPtr^[KeyNr]^.KeyLen + 9) + 6; + IsamBlockRead(IFBPtr^.DiaF, PPtr^ [4], K + 4); {Read rest} + if not IsamOK then Exit; + Move(PPtr^ [K], PageRef, 4); + Move(PPtr^ [K+4], Page.BckwPageRef, 4); + IFBlPtr := IFBPtr; + SaveBuffered := False; + UpDated := False; + IsamUnPack(Page, IFBPtr^.DIDPtr^[KeyNr]^.KeyLen); + IsamPutPage(IPgPtr, True); + IFBlPtr := Nil; + end; + end; + {----} + begin {Repair} + IsamClearOK; + IsamDestroyPages(IFBPtr); + with IFBPtr^ do begin + IsamLongSeek(DiaF, 0); + if not IsamOK then begin + IsamError := RepError; + Exit; + end; + IsamBlockWrite(DiaF, IST, 1); + if not IsamOK then begin + IsamError := RepError; + Exit; + end; + repeat + IST := 0; + IsamBlockRead(DiaF, IST, 2); + if not IsamOK then Exit; + case IST of + 1..MaxPageSize : RestorePage; {!!.42} + 1000 : RestoreInfoRec; + 2000 : Exit; + else + IsamOK := False; + IsamError := RepError; + Exit; + end; {Case} + if not IsamOK then Exit; + until False; + end; + end; + {------} +begin {IsamRepairFileBlock} + if IFBPtr^.ReadOnlyFB then begin + IsamOK := False; + IsamError := 10430; + Exit + end; +{$IFDEF UseEMSHeap} + if EMSHeapIsUsed then begin + FrameAlreadySaved := True; + if UserSaveEMSHandle = 0 then begin + FrameAlreadySaved := False; + UserSaveEMSHandle := SaveEMSCtxt; + {$IFDEF EMSDisturbance} + RestoreEMSCtxt(OwnSaveEMSHandle); + {$ENDIF} + end; + end; +{$ENDIF} + Repair; +{$IFDEF UseEMSHeap} + if EMSHeapIsUsed then begin + if not FrameAlreadySaved then begin + {$IFDEF EMSDisturbance} + OwnSaveEMSHandle := SaveEMSCtxt; + {$ENDIF} + RestoreEMSCtxt(UserSaveEMSHandle); + UserSaveEMSHandle := 0; + end; + end; +{$ENDIF} + if IsamError = 0 then begin + if (IFBPtr^.NSP = Nil) or IsamNetEmu then begin + IsamFlushDOSDat(IFBPtr); + if not IsamOK then begin + IsamError := RepError; + Exit; + end; + if IFBPtr^.NrOfKeys > 0 then begin + IsamFlushDOSIx(IFBPtr); + if not IsamOK then begin + IsamError := RepError; + Exit; + end; + end; + end; + IsamReduceDiaFile(IFBPtr); + end + else begin + if IsamError = 10070 then begin + IsamClearOK; + IsamReduceDiaFile(IFBPtr); + end + else begin + IsamError := RepError; + end; + end; +end; + + +procedure IsamFindKey( IFBPtr : IsamFileBlockPtr; + Key : Word; + var UserDatRef : LongInt; + var UserKey : IsamKeyStr ); +var + RefNr : LongInt; + C,K,L,R : Integer; + IPgPtr : IsamPagePtr; + OK : Boolean; +begin + with IFBPtr^, DIDPtr^[Key]^ do begin + SequentialOK := False; + OK := False; + PathInd := 0; + RefNr := RootRef; + while (RefNr <> 0) and (not OK) do begin + Inc (PathInd); + Path [PathInd].PageRef := RefNr; + IsamGetPage(IFBPtr, RefNr, Key, IPgPtr); + if not IsamOK then Exit; + with IPgPtr^ do begin + L := 1; + R := ItemsOnPage; + repeat + K := (L + R) Shr 1; + C := IsamCompKeys(UserKey, ItemArray [K].KeyStr, + UserDatRef, ItemArray [K].DataRef, + AllowDupKeys); + if C <= 0 then + R := Pred (K); + if C >= 0 then + L := Succ (K); + until R < L; + if L - R > 1 then begin + UserDatRef := ItemArray [K].DataRef; + R := K; + OK := True; + end + else begin + if R = 0 then begin + RefNr := BckwPageRef; + end + else begin + RefNr := ItemArray [R].PageRef; + end; + end; + end; + Path [PathInd].ItemArrInd := R; + end; + if not OK then begin + while (PathInd > 0) and (Path [PathInd].ItemArrInd = 0) do begin + Dec(PathInd); + end; + end; + SequentialOK := True; + end; + IsamOK := OK; +end; + + +procedure IsamAddKey( IFBPtr : IsamFileBlockPtr; + Key : Word; + UserDatRef : LongInt; + var UserKey : IsamKeyStr ); +var + IPgRef1, + IPgRef2 : LongInt; + C, K, L : Integer; + OverRun, + OK, ADK : Boolean; + IPgPtr1, + IPgPtr2 : IsamPagePtr; + IItem1, + IItem2 : IsamItem; + IR : IsamInfoRec; + RefList : Array [1..30] Of LongInt; {At least 3 * (MaxHeigth + 1)} + {------} + procedure InitRefList; + begin + RefList [1] := 0; + end; + {------} + function IsInRefList(Ref : LongInt) : Boolean; + var + I : Integer; + begin + IsInRefList := True; + I := 1; + while RefList [I] <> 0 do begin + if Ref = RefList [I] then Exit; + Inc (I); + end; + RefList [Succ (I)] := 0; + RefList [I] := Ref; + IsInRefList := False; + end; + {------} + procedure Search(IPgRef1 : LongInt; RV : Integer; IPgRef1V : LongInt); + var + R : Integer; + {----} + function BalanceDone : Boolean; + var + IPgRef3 : LongInt; + IPgPtr1V, IPgPtr3 : IsamPagePtr; + right : Boolean; + {--} + procedure Balance; + var + TRef : LongInt; + I, K, M, N : Integer; + CurPageSize : Word; {!!.42} + begin + CurPageSize := IFBPtr^.DIDPtr^[Key]^.UsedPageSize; {!!.42} + with IPgPtr1^ do begin + if right then begin + Inc (RV); + Inc (R); + TRef := IPgPtr1V^.ItemArray [RV].PageRef; + IPgPtr1V^.ItemArray [RV].PageRef := IPgPtr3^.BckwPageRef; + K := 2 + CurPageSize + IPgPtr3^.ItemsOnPage; {!!.42} + M := Succ(K Shr 1); + K := K - M - IPgPtr3^.ItemsOnPage; + for I := IPgPtr3^.ItemsOnPage downto 1 do begin + IPgPtr3^.ItemArray [I+K] := IPgPtr3^.ItemArray [I]; + end; + IPgPtr3^.ItemArray [K] := IPgPtr1V^.ItemArray [RV]; + if M = R then begin + for I := R to CurPageSize do begin {!!.42} + IPgPtr3^.ItemArray [Succ (I-R)] := ItemArray [I]; + end; + IPgPtr1V^.ItemArray [RV] := IItem1; + end + else begin + if M > R then begin + for I := M to CurPageSize do begin {!!.42} + IPgPtr3^.ItemArray [Succ (I-M)] := ItemArray [I]; + end; + IPgPtr1V^.ItemArray [RV] := ItemArray [Pred (M)]; + for I := M-2 downto R do begin + ItemArray [Succ (I)] := ItemArray [I]; + end; + ItemArray [R] := IItem1; + end + else begin + for I := R to CurPageSize do begin {!!.42} + IPgPtr3^.ItemArray [Succ (I-M)] := ItemArray [I]; + end; + IPgPtr3^.ItemArray [R-M] := IItem1; + for I := Succ (M) to Pred (R) do begin + IPgPtr3^.ItemArray [I-M] := ItemArray [I]; + end; + IPgPtr1V^.ItemArray [RV] := ItemArray [M]; + end; + end; + IPgPtr3^.BckwPageRef := IPgPtr1V^.ItemArray [RV].PageRef; + IPgPtr1V^.ItemArray [RV].PageRef := TRef; + ItemsOnPage := Pred (M); + Inc (IPgPtr3^.ItemsOnPage, K); + end + else begin + Inc (R); + TRef := IPgPtr1V^.ItemArray [RV].PageRef; + IPgPtr1V^.ItemArray [RV].PageRef := BckwPageRef; + N := Succ (IPgPtr3^.ItemsOnPage); + M := (2 + CurPageSize + N) Shr 1; {!!.42} + K := M - N; + IPgPtr3^.ItemArray [N] := IPgPtr1V^.ItemArray [RV]; + if K = R then begin + for I := 1 to Pred (K) do begin + IPgPtr3^.ItemArray [I+N] := ItemArray [I]; + end; + for I := R to CurPageSize do begin {!!.42} + ItemArray [Succ (I-R)] := ItemArray [I]; + end; + IPgPtr1V^.ItemArray [RV] := IItem1; + end + else begin + if K < R then begin + for I := 1 to Pred (K) do begin + IPgPtr3^.ItemArray [I+N] := ItemArray [I]; + end; + IPgPtr1V^.ItemArray [RV] := ItemArray [K]; + for I := Succ (K) to Pred (R) do begin + ItemArray [I-K] := ItemArray [I]; + end; + ItemArray [R-K] := IItem1; + for I := R to CurPageSize do begin {!!.42} + ItemArray [Succ (I-K)] := ItemArray [I]; + end; + end + else begin + for I := 1 to Pred (R) do begin + IPgPtr3^.ItemArray [I+N] := ItemArray [I]; + end; + IPgPtr3^.ItemArray [R+N] := IItem1; + for I := R to K-2 do begin + IPgPtr3^.ItemArray [Succ (I+N)] := ItemArray [I]; + end; + IPgPtr1V^.ItemArray [RV] := ItemArray [Pred (K)]; + for I := K to CurPageSize do begin {!!.42} + ItemArray [Succ (I-K)] := ItemArray [I]; + end; + end; + end; + IPgPtr1^.BckwPageRef := IPgPtr1V^.ItemArray [RV].PageRef; + IPgPtr1V^.ItemArray [RV].PageRef := TRef; + ItemsOnPage := CurPageSize - Pred (K); {!!.42} + Inc (IPgPtr3^.ItemsOnPage, K); + end; + end; + end; + {----} + begin + BalanceDone := False; + if RV = -1 then Exit; + IsamGetPage(IFBPtr, IPgRef1V, Key, IPgPtr1V); + if not IsamOK then Exit; + with IPgPtr1V^ do begin + right := RV < ItemsOnPage; + if right then begin + IPgRef3 := ItemArray [Succ (RV)].PageRef; + end + else begin + if RV > 1 then begin + IPgRef3 := ItemArray [Pred (RV)].PageRef; + end + else begin + IPgRef3 := BckwPageRef; + end; + end; + IsamGetPage(IFBPtr, IPgRef3, Key, IPgPtr3); + if not IsamOK then Exit; + if IPgPtr3^.ItemsOnPage = + IFBPtr^.DIDPtr^[Key]^.UsedPageSize then Exit; {!!.42} + end; + if IFBPtr^.SaveFB then begin + if not IsInRefList(IPgRef1V) then begin + IsamSavePage(IPgPtr1V^); + if not IsamOK then Exit; + end; + if not IsInRefList(IPgRef3) then begin + IsamSavePage(IPgPtr3^); + if not IsamOK then Exit; + end; + end; + Balance; + IsamUpDatePage(IPgPtr3); + IsamUpDatePage(IPgPtr1V); + OverRun := False; + BalanceDone := True; + end; + {----} + procedure Insert; + type + IsamItemInAr = Array [0..0] Of IsamItem; + var + I : Integer; + CurPageSize : Word; {!!.42} + begin + CurPageSize := IFBPtr^.DIDPtr^[Key]^.UsedPageSize; {!!.42} + IsamGetPage(IFBPtr, IPgRef1, Key, IPgPtr1); + if not IsamOK then Exit; + with IPgPtr1^ do begin + if IFBPtr^.SaveFB then begin + if not IsInRefList(IPgRef1) then begin + IsamSavePage(IPgPtr1^); + if not IsamOK then Exit; + end; + end; + if ItemsOnPage < CurPageSize then begin {!!.42} + Inc (ItemsOnPage); + Move(ItemArray [Succ(R)], ItemArray [R+2], + (ItemsOnPage - Succ (R)) * SizeOf (IsamItemInAr)); + ItemArray [Succ (R)] := IItem1; + OverRun := False; + end + else begin + if not BalanceDone then begin + if not IsamOK then Exit; + with IFBPtr^ do begin + IsamNewPage(IFBPtr, IPgRef2, IPgPtr2, Key); + if not IsamOK then Exit; + if SaveFB then begin + if not IsInRefList(-2) then begin + if IsamFirstFreeChanged(IFBPtr, Key) then begin + IsamSaveGivenInfoRec(IFBPtr, Key, IR, + DIDPtr^[Key]^.FirstFree); + end + else begin + IsamSaveGivenInfoRec(IFBPtr, Key, IR, -2); + end; + if not IsamOK then Exit; + end; + end; + end; + if R <= (CurPageSize Shr 1) then begin {!!.42} + if R = CurPageSize Shr 1 then begin {!!.42} + IItem2 := IItem1; + end + else begin + IItem2 := ItemArray [CurPageSize Shr 1]; {!!.42} + for I := CurPageSize Shr 1 downto R + 2 do begin {!!.42} + ItemArray [I] := ItemArray [Pred (I)]; + end; + ItemArray [Succ (R)] := IItem1; + end; + for I := 1 to CurPageSize Shr 1 do begin {!!.42} + IPgPtr2^.ItemArray [I] := + ItemArray [I + CurPageSize Shr 1]; {!!.42} + end; + end + else begin + R := R - CurPageSize Shr 1; {!!.42} + IItem2 := ItemArray [Succ (CurPageSize Shr 1)]; {!!.42} + for I := 1 to Pred (R) do begin + IPgPtr2^.ItemArray [I] := + ItemArray [Succ (I + CurPageSize Shr 1)]; {!!.42} + end; + IPgPtr2^.ItemArray [R] := IItem1; + for I := Succ (R) to CurPageSize Shr 1 do begin {!!.42} + IPgPtr2^.ItemArray [I] := + ItemArray [I + CurPageSize Shr 1]; {!!.42} + end; + end; + ItemsOnPage := CurPageSize Shr 1; {!!.42} + IPgPtr2^.ItemsOnPage := CurPageSize Shr 1; {!!.42} + IPgPtr2^.BckwPageRef := IItem2.PageRef; + IItem2.PageRef := IPgRef2; + IItem1 := IItem2; + IsamUpdatePage(IPgPtr2); + end; + end; + end; + IsamUpdatePage(IPgPtr1); + end; + {------} + begin {Search} + if IPgRef1 = 0 then begin + OverRun := True; + with IItem1 do begin + Move(UserKey, KeyStr, SizeOf (IsamKeyStr)); + DataRef := UserDatRef; + PageRef := 0; + end; + end + else begin + IsamGetPage(IFBPtr, IPgRef1, Key, IPgPtr1); + if not IsamOK then Exit; + with IPgPtr1^ do begin + L := 1; + R := ItemsOnPage; + ADK := IFBPtr^.DIDPtr^[Key]^.AllowDupKeys; + repeat + K := (L + R) Shr 1; + C := IsamCompKeys(UserKey, + ItemArray [K].KeyStr, + UserDatRef, + ItemArray [K].DataRef, + ADK ); + if C <= 0 then + R := Pred (K); + if C >= 0 then + L := Succ (K); + until R < L; + if L - R > 1 then begin + OK := False; + OverRun := False; + end + else begin + if R = 0 then begin + Search(BckwPageRef, R, IPgRef1); + end + else begin + Search(ItemArray [R].PageRef, R, IPgRef1); + end; + if not IsamOK then Exit; + if OverRun then + Insert; + end; + end; + end; + end; {Search} + {------} +begin {IsamAddKey} + InitRefList; + IsamSetDataBufferedFlag(IFBPtr); + if not IsamOK then Exit; + with IFBPtr^, DIDPtr^[Key]^ do begin + if SaveFB then + IsamCopyInfoRecToIR(IFBPtr, Key, IR); + SequentialOK := False; + OK := True; + Search(RootRef, -1, 0); + if not IsamOK then Exit; + if OverRun then begin + IPgRef1 := RootRef; + IsamNewPage(IFBPtr, RootRef, IPgPtr1, Key); + if not IsamOK then Exit; + if SaveFB then begin + if not IsInRefList(-2) then begin + if IsamFirstFreeChanged(IFBPtr, Key) then begin + IsamSaveGivenInfoRec(IFBPtr, Key, IR, + DIDPtr^[Key]^.FirstFree); + end + else begin + IsamSaveGivenInfoRec(IFBPtr, Key, IR, -2); + end; + if not IsamOK then Exit; + end; + end; + with IPgPtr1^ do begin + ItemsOnPage := 1; + BckwPageRef := IPgRef1; + ItemArray [1] := IItem1; + end; + IsamUpdatePage(IPgPtr1); + end; + if SaveFB then begin + if not IsInRefList(-2) then begin + {-if not yet stored, no change was made up to now} + IsamSaveGivenInfoRec(IFBPtr, Key, IR, -2); + if not IsamOK then Exit; + end; + if (NSP = Nil) or IsamNetEmu then begin + IsamFlushDOSDia(IFBPtr, False); + if not IsamOK then Exit; + IsamResetSaveBuffered; + end; + if OK then begin + Inc (NumKeys); + InfoRecChanged := True; + end; + IsamFlushPageInfo(IFBPtr, False); + if not IsamOK then Exit; + if (NSP = Nil) or IsamNetEmu then begin + IsamFlushDOSIx(IFBPtr); + if not IsamOK then Exit; + end; + end + else begin + if OK then begin + Inc (NumKeys); + InfoRecChanged := True; + end; + end; + end; + IsamOK := OK; +end; + + +procedure IsamDeleteKey( IFBPtr : IsamFileBlockPtr; + Key : Word; + UserDatRef : LongInt; + var UserKey : IsamKeyStr ); +var + OK, + UnderRun : Boolean; + IPgPtr : IsamPagePtr; + RefList : Array [1..30] Of LongInt; {At least 3 * (MaxHeigth + 1)} + IR : IsamInfoRec; + {------} + procedure InitRefList; + begin + RefList [1] := 0; + end; + {------} + function IsInRefList(Ref : LongInt) : Boolean; + var + I : Integer; + begin + IsInRefList := True; + I := 1; + while RefList [I] <> 0 do begin + if Ref = RefList [I] then Exit; + Inc (I); + end; + RefList [Succ (I)] := 0; + RefList [I] := Ref; + IsInRefList := False; + end; + {------} + procedure Delete2(RefNr : LongInt); + type + IsamItemInAr = Array [0..0] Of IsamItem; + var + C, K, L, R : Integer; + IPgRef00 : LongInt; + IPgPtr : IsamPagePtr; + ADK : Boolean; + {----} + procedure UnderFlow(RefNr, IPgRef2 : LongInt; R : Integer); + var + I, K, IItem0 : Integer; + IPgRef0 : LongInt; + IPgPtr, IPgPtr2, IPgPtr0 : IsamPagePtr; + CurPageSize : Word; {!!.42} + begin + CurPageSize := IFBPtr^.DIDPtr^[Key]^.UsedPageSize; {!!.42} + IsamGetPage(IFBPtr, RefNr, Key, IPgPtr); + if not IsamOK then Exit; + IsamGetPage(IFBPtr, IPgRef2, Key, IPgPtr2); + if not IsamOK then Exit; + if R < IPgPtr^.ItemsOnPage then begin + Inc (R); + IPgRef0 := IPgPtr^.ItemArray [R].PageRef; + IsamGetPage(IFBPtr, IPgRef0, Key, IPgPtr0); + if not IsamOK then Exit; + if IFBPtr^.SaveFB then begin + if not IsInRefList(RefNr) then begin + IsamSavePage(IPgPtr^); + if not IsamOK then Exit; + end; + if not IsInRefList(IPgRef2) then begin + IsamSavePage(IPgPtr2^); + if not IsamOK then Exit; + end; + if not IsInRefList(IPgRef0) then begin + IsamSavePage(IPgPtr0^); + if not IsamOK then Exit; + end; + end; + K := (Succ (IPgPtr0^.ItemsOnPage - CurPageSize Shr 1)) {!!.42} + Shr 1; + IPgPtr2^.ItemArray [CurPageSize Shr 1] := {!!.42} + IPgPtr^.ItemArray [R]; + IPgPtr2^.ItemArray [CurPageSize Shr 1].PageRef := {!!.42} + IPgPtr0^.BckwPageRef; + if K > 0 then begin + for I := 1 to Pred (K) do begin + IPgPtr2^.ItemArray [I + CurPageSize Shr 1] := {!!.42} + IPgPtr0^.ItemArray [I]; + end; + IPgPtr^.ItemArray [R] := IPgPtr0^.ItemArray [K]; + IPgPtr^.ItemArray [R].PageRef := IPgRef0; + IPgPtr0^.BckwPageRef := IPgPtr0^.ItemArray [K].PageRef; + IPgPtr0^.ItemsOnPage := IPgPtr0^.ItemsOnPage - K; + for I := 1 to IPgPtr0^.ItemsOnPage do begin + IPgPtr0^.ItemArray [I] := IPgPtr0^.ItemArray [I+K]; + end; + IPgPtr2^.ItemsOnPage := Pred (CurPageSize Shr 1 + K); {!!.42} + UnderRun := False; + IsamUpdatePage (IPgPtr0); + end + else begin + for I := 1 to CurPageSize Shr 1 do begin {!!.42} + IPgPtr2^.ItemArray [I + CurPageSize Shr 1] := {!!.42} + IPgPtr0^.ItemArray [I]; + end; + for I := R to Pred(IPgPtr^.ItemsOnPage) do begin + IPgPtr^.ItemArray [I] := IPgPtr^.ItemArray [Succ(I)]; + end; + IPgPtr2^.ItemsOnPage := CurPageSize; {!!.42} + Dec (IPgPtr^.ItemsOnPage); + IsamReturnPage (IPgPtr0); + if not IsamOK then Exit; + UnderRun := IPgPtr^.ItemsOnPage < CurPageSize Shr 1; {!!.42} + end; + IsamUpdatePage(IPgPtr2); + end + else begin + if R = 1 then begin + IPgRef0 := IPgPtr^.BckwPageRef; + end + else begin + IPgRef0 := IPgPtr^.ItemArray [Pred(R)].PageRef; + end; + IsamGetPage(IFBPtr, IPgRef0, Key, IPgPtr0); + if not IsamOK then Exit; + if IFBPtr^.SaveFB then begin + if not IsInRefList(RefNr) then begin + IsamSavePage(IPgPtr^); + if not IsamOK then Exit; + end; + if not IsInRefList(IPgRef2) then begin + IsamSavePage(IPgPtr2^); + if not IsamOK then Exit; + end; + if not IsInRefList(IPgRef0) then begin + IsamSavePage(IPgPtr0^); + if not IsamOK then Exit; + end; + end; + IItem0 := Succ (IPgPtr0^.ItemsOnPage); + K := (IItem0 - CurPageSize Shr 1) Shr 1; {!!.42} + if K > 0 then begin + for I := Pred (CurPageSize Shr 1) downto 1 do begin {!!.42} + IPgPtr2^.ItemArray [I+K] := IPgPtr2^.ItemArray [I]; + end; + IPgPtr2^.ItemArray [K] := IPgPtr^.ItemArray [R]; + IPgPtr2^.ItemArray [K].PageRef := IPgPtr2^.BckwPageRef; + Dec (IItem0, K); + for I := Pred (K) downto 1 do begin + IPgPtr2^.ItemArray [I] := IPgPtr0^.ItemArray [I+IItem0]; + end; + IPgPtr2^.BckwPageRef := IPgPtr0^.ItemArray [IItem0].PageRef; + IPgPtr^.ItemArray [R] := IPgPtr0^.ItemArray [IItem0]; + IPgPtr^.ItemArray [R].PageRef := IPgRef2; + IPgPtr0^.ItemsOnPage := Pred (IItem0); + IPgPtr2^.ItemsOnPage := Pred (CurPageSize Shr 1 + K); {!!.42} + UnderRun := False; + IsamUpdatePage(IPgPtr2); + end + else begin + IPgPtr0^.ItemArray [IItem0] := IPgPtr^.ItemArray [R]; + IPgPtr0^.ItemArray [IItem0].PageRef := IPgPtr2^.BckwPageRef; + for I := 1 to Pred (CurPageSize Shr 1) do begin {!!.42} + IPgPtr0^.ItemArray [I+IItem0] := IPgPtr2^.ItemArray [I]; + end; + IPgPtr0^.ItemsOnPage := CurPageSize; {!!.42} + Dec (IPgPtr^.ItemsOnPage); + IsamReturnPage(IPgPtr2); + if not IsamOK then Exit; + UnderRun := IPgPtr^.ItemsOnPage < CurPageSize Shr 1; {!!.42} + end; + IsamUpdatePage (IPgPtr0); + end; + IsamUpdatePage(IPgPtr); + end; (* UnderFlow *) + {----} + procedure Delete1(IPgRef2 : LongInt); + var + C : Integer; + IPgRef00 : LongInt; + IPgPtr2 : IsamPagePtr; + begin + IsamGetPage(IFBPtr, IPgRef2, Key, IPgPtr2); + if not IsamOK then Exit; + with IPgPtr2^ do begin + IPgRef00 := ItemArray [ItemsOnPage].PageRef; + if IPgRef00 <> 0 then begin + C := ItemsOnPage; + Delete1(IPgRef00); + if not IsamOK then Exit; + if UnderRun then + UnderFlow(IPgRef2, IPgRef00, C); + end + else begin + IsamGetPage(IFBPtr, RefNr, Key, IPgPtr); + if not IsamOK then Exit; + if IFBPtr^.SaveFB then begin + if not IsInRefList(RefNr) then begin + IsamSavePage(IPgPtr^); + if not IsamOK then Exit; + end; + if not IsInRefList(IPgRef2) then begin + IsamSavePage(IPgPtr2^); + if not IsamOK then Exit; + end; + end; + ItemArray [ItemsOnPage].PageRef := + IPgPtr^.ItemArray [K].PageRef; + IPgPtr^.ItemArray [K] := ItemArray [ItemsOnPage]; + Dec (ItemsOnPage); + UnderRun := ItemsOnPage < + IFBPtr^.DIDPtr^[Key]^.UsedPageSize Shr 1; {!!.42} + IsamUpdatePage(IPgPtr); + IsamUpdatePage(IPgPtr2); + end; + end; + end; (* Delete1 *) + {------} + begin (* Delete2 *) + if RefNr = 0 then begin + OK := False; + UnderRun := False; + end + else begin + IsamGetPage(IFBPtr, RefNr, Key, IPgPtr); + if not IsamOK then Exit; + with IPgPtr^ do begin + L := 1; + R := ItemsOnPage; + ADK := IFBPtr^.DIDPtr^[Key]^.AllowDupKeys; + repeat + K := (L + R) Shr 1; + C := IsamCompKeys(UserKey, + ItemArray [K].KeyStr, + UserDatRef, + ItemArray [K].DataRef, + ADK ); + if C <= 0 then + R := Pred (K); + if C >= 0 then + L := Succ (K); + until L > R; + if R = 0 then begin + IPgRef00 := BckwPageRef; + end + else begin + IPgRef00 := ItemArray [R].PageRef; + end; + if L - R > 1 then begin + UserDatRef := ItemArray [K].DataRef; + if IPgRef00 = 0 then begin + if IFBPtr^.SaveFB then begin + if not IsInRefList(RefNr) then begin + IsamSavePage(IPgPtr^); + if not IsamOK then Exit; + end; + end; + Dec (ItemsOnPage); + UnderRun := ItemsOnPage < {!!.42} + IFBPtr^.DIDPtr^[Key]^.UsedPageSize Shr 1; + Move(ItemArray [Succ (K)], ItemArray [K], + (ItemsOnPage - Pred (K)) * SizeOf (IsamItemInAr)); + IsamUpdatePage(IPgPtr); + end + else begin + Delete1(IPgRef00); + if not IsamOK then Exit; + if UnderRun then + UnderFlow(RefNr, IPgRef00, R); + end; + end + else begin + Delete2(IPgRef00); + if not IsamOK then Exit; + if UnderRun then + UnderFlow(RefNr, IPgRef00, R); + end; + end; + end; + end; (* Delete2 *) + {------} +begin (* DeleteKey *) + InitRefList; + IsamSetDataBufferedFlag(IFBPtr); + if not IsamOK then Exit; + with IFBPtr^, DIDPtr^[Key]^ do begin + if SaveFB then begin + if not IsInRefList(-2) then begin {Always True} + IsamCopyInfoRecToIR(IFBPtr, Key, IR); + IsamSaveGivenInfoRec(IFBPtr, Key, IR, -2); + if not IsamOK then Exit; + end; + end; + SequentialOK := False; + OK := True; + Delete2(RootRef); + if not IsamOK then Exit; + if UnderRun then begin + IsamGetPage(IFBPtr, RootRef, Key, IPgPtr); + if not IsamOK then Exit; + if IPgPtr^.ItemsOnPage = 0 then begin + if SaveFB then begin + if not IsInRefList(RootRef) then begin + IsamSavePage(IPgPtr^); + if not IsamOK then Exit; + end; + end; + RootRef := IPgPtr^.BckwPageRef; + IsamReturnPage(IPgPtr); + if not IsamOK then Exit; + end; + end; + if SaveFB then begin + if (NSP = Nil) or IsamNetEmu then begin + IsamFlushDOSDia(IFBPtr, False); + if not IsamOK then Exit; + IsamResetSaveBuffered; + end; + if OK then begin + Dec (NumKeys); + InfoRecChanged := True; + end; + IsamFlushPageInfo(IFBPtr, False); + if not IsamOK then Exit; + if (NSP = Nil) or IsamNetEmu then begin + IsamFlushDOSIx(IFBPtr); + if not IsamOK then Exit; + end; + end + else begin + if OK then begin + Dec (NumKeys); + InfoRecChanged := True; + end; + end; + end; + IsamOK := OK; +end; diff --git a/src/wc_sdk/iscompat.pas b/src/wc_sdk/iscompat.pas new file mode 100644 index 0000000..eaf5573 --- /dev/null +++ b/src/wc_sdk/iscompat.pas @@ -0,0 +1,1075 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$F-,V-,B-,S-,I-,R-} + {$IFDEF CanSetOvrflowCheck} + {$Q-} + {$ENDIF} + +Unit ISCompat; + +Interface + +Uses + Filer; + +type + IsamPageStackState = (StateUnknown, StateBadDialog, + StateInvalid, StateValid); + +Var + IsamFehler : Integer Absolute IsamError; + +const + DynamicNetType : NetSupportType = NoNet; + +var + InternalDosError : word absolute IsamDOSError; + InternalDosFunction : word absolute IsamDOSFunc; + IsamDelayForRetry : word absolute IsamDelayBetwLocks; + + Procedure InitIsam; + + Function IsamErrorClass : Integer; + + Procedure ForceWritingMark ( FFM : Boolean ); + + Procedure PutRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Source ); + + Procedure GetRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest ); + + Procedure AddRec ( IFBPtr : IsamFileBlockPtr; + Var RefNr : LongInt; + Var Source ); + + Function UsedRecs ( IFBPtr : IsamFileBlockPtr ) : LongInt; + + Function UsedKeys ( IFBPtr : IsamFileBlockPtr; Key : Integer ) : LongInt; + + Function FreeRecs ( IFBPtr : IsamFileBlockPtr ) : LongInt; + + Function FileLen ( IFBPtr : IsamFileBlockPtr ) : LongInt; + + Function DatNrOfKeys ( IFBPtr : IsamFileBlockPtr ) : Integer; + + Function DatRecordSize ( IFBPtr : IsamFileBlockPtr ) : LongInt; + + Function KeyRecordSize ( IFBPtr : IsamFileBlockPtr ) : LongInt; + + Function MinimumDatKeys ( IFBPtr : IsamFileBlockPtr; Space : LongInt ) + : LongInt; + + Function MinSpaceForPageStack : LongInt; + + Procedure DeleteRec ( IFBPtr : IsamFileBlockPtr; RefNr : LongInt ); + + Function GetPageStack ( Free : LongInt ) : Integer; + + Procedure ReleasePageStack; + + Procedure FlushIsamBuffers; + + Procedure FlushAllFileBlocks; + + Procedure FlushBuffer ( IFBPtr : IsamFileBlockPtr ); + + Procedure FlushFileBlock ( IFBPtr : IsamFileBlockPtr ); + + Procedure MakeFileBlock ( Var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName; + DatSLen : LongInt; + NumberOfKeys : Integer; + IID : IsamIndDescr); + + Procedure OpenFileBlock ( Var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName ); + + Procedure OpenSaveFileBlock ( Var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName ); + + Procedure CloseFileBlock ( Var IFBPtr : IsamFileBlockPtr ); + + Procedure CloseAllFileBlocks; + + Procedure DeleteFileBlock ( FName : IsamFileBlockName ); + + Function FileBlockIsOpen ( IFBPtr : IsamFileBlockPtr ) : Boolean; + + Procedure ClearKey ( IFBPtr : IsamFileBlockPtr; Key : Integer ); + + Procedure NextKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + + Procedure PrevKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + + Procedure FindKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + UserKey : IsamKeyStr ); + + Procedure SearchKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + + Procedure FindKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr; + NotFoundSearchDirection : Integer ); + + Procedure SearchKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + + Function KeyExists ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + UserDatRef : LongInt; + UserKey : IsamKeyStr ) : Boolean; + + Procedure NextDiffKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + + Procedure PrevDiffKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + + Procedure AddKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + UserDatRef : LongInt; + UserKey : IsamKeyStr ); + + Procedure DeleteKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + UserDatRef : LongInt; + UserKey : IsamKeyStr ); + + Procedure DeleteAllKeys ( IFBPtr : IsamFileBlockPtr; + Key : Integer ); + + Procedure EnableSearchForSequential ( IFBPtr : IsamFileBlockPtr; + Key : Integer ); + + Procedure DisableSearchForSequential ( IFBPtr : IsamFileBlockPtr; + Key : Integer ); + + Procedure TestSearchForSequential ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var TSFS : Boolean ); + + Procedure GetApprRelPos ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var RelPos : Word; + Scale : Word; + UserKey : IsamKeyStr; + UserDatRef : LongInt ); + + Procedure GetApprKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + RelPos : Word; + Scale : Word; + Var UserKey : IsamKeyStr; + Var UserDatRef : LongInt ); + + procedure InitNetIsam(NetExpected : Boolean); {!!} + + Procedure ExitNetIsam; + + Procedure ReadLockFileBlock ( IFBPtr : IsamFileBlockPtr ); + + Procedure LockFileBlock ( IFBPtr : IsamFileBlockPtr ); + + Procedure UnLockFileBlock ( IFBPtr : IsamFileBlockPtr ); + + Procedure ReadLockAllOpenFileBlocks; + + Procedure LockAllOpenFileBlocks; + + Procedure UnLockAllOpenFileBlocks; + + Procedure LockRec ( IFBPtr : IsamFileBlockPtr; Ref : LongInt ); + + Procedure UnLockRec ( IFBPtr : IsamFileBlockPtr; Ref : LongInt ); + + Procedure GetRecordInfo ( IFBPtr : IsamFileBlockPtr; + Ref : LongInt; + Var Start, Len : LongInt; + Var Handle : Word ); + + Function FileBlockIsLocked ( IFBPtr : IsamFileBlockPtr ) : Boolean; + + Function FileBlockIsReadLocked ( IFBPtr : IsamFileBlockPtr ) : Boolean; + + Function UsedNetRecs ( IFBPtr : IsamFileBlockPtr ) : LongInt; + + Function UsedNetKeys ( IFBPtr : IsamFileBlockPtr; Key : Integer ) : LongInt; + + Function FreeNetRecs ( IFBPtr : IsamFileBlockPtr ) : LongInt; + + Function NetFileLen ( IFBPtr : IsamFileBlockPtr ) : LongInt; + + Procedure GetNetRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest ); + + Procedure FindNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + UserKey : IsamKeyStr ); + + Procedure SearchNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + + Procedure FindNetKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr; + NotFoundSearchDirection : Integer ); + + Procedure SearchNetKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + + Function NetKeyExists ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + UserDatRef : LongInt; + UserKey : IsamKeyStr ) : Boolean; + + Procedure NextNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + + Procedure PrevNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + + Procedure ClearNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer ); + + Procedure NextDiffNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + + Procedure PrevDiffNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + + Procedure GetNetRecInSpiteOfLock ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest ); + + Procedure GetNetRecReadOnly ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest ); + + + Procedure AddNetRec ( IFBPtr : IsamFileBlockPtr; + Var RefNr : LongInt; + Var Source ); + + Procedure PutNetRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Source ); + + Procedure DeleteNetRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt ); + + Procedure AddNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + UserDatRef : LongInt; + UserKey : IsamKeyStr ); + + Procedure DeleteNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + UserDatRef : LongInt; + UserKey : IsamKeyStr ); + + Procedure DeleteAllNetKeys ( IFBPtr : IsamFileBlockPtr; + Key : Integer ); + + Procedure PutNetRecInSpiteOfLock ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Source ); + + Procedure MakeNetFileBlock ( Var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName; + DatSLen : LongInt; + AnzKey : Integer; + IID : IsamIndDescr ); + + Procedure CloseNetFileBlock ( Var IFBPtr : IsamFileBlockPtr ); + + Procedure CloseEachFileBlock; + + Procedure OpenNetFileBlock ( Var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName ); + + Procedure OpenSaveNetFileBlock ( Var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName ); + + Procedure DeleteNetFileBlock ( FName : IsamFileBlockName ); + + Function SetDosRetry ( NrOfRetries, WaitTime : Integer ) : Boolean; + + Function NetSupported : NetSupportType; + + Function NoNetCompiled : Boolean; + + Function IsNetFileBlock ( IFBPtr : IsamFileBlockPtr ) : Boolean; + + Procedure GetApprNetRelPos ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var RelPos : Word; + Scale : Word; + UserKey : IsamKeyStr; + UserDatRef : LongInt ); + + Procedure GetApprNetKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + RelPos : Word; + Scale : Word; + Var UserKey : IsamKeyStr; + Var UserDatRef : LongInt ); + + Procedure ForceNetBufferWriteThrough ( DoIt : Boolean ); + + {!!} {Routines that were in FILER.PAS but not in German version} + + function FileBlockLocked(IFBPtr : IsamFileBlockPtr) : Boolean; + + function FileNameFromIFBPtr(IFBPtr : IsamFileBlockPtr) : IsamFileBlockName; + + function PageStackValid(IFBPtr : IsamFileBlockPtr; KeyNr : Integer) : IsamPageStackState; + + procedure IsamFileSize(F : IsamFile; var Size : LongInt); + + procedure RemoveActiveLocks(IFBPtr : IsamFileBlockPtr); + + +Implementation + +Const + NetIsExpected : Boolean = False; {!!} + + + Procedure InitIsam; + Begin + IsamClearOK; + DynamicNetType := NoNet; {!!} + NetIsExpected := False; {!!} + End; + + Function IsamErrorClass : Integer; + Begin + IsamErrorClass := BTIsamErrorClass; + End; + + Procedure ForceWritingMark ( FFM : Boolean ); + Begin + BTForceWritingMark ( FFM ); + End; + + Procedure PutRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Source ); + Begin + BTPutRec ( IFBPtr, RefNr, Source, False ); + End; + + Procedure GetRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest ); + Begin + BTGetRec ( IFBPtr, RefNr, Dest, False ); + End; + + Procedure AddRec ( IFBPtr : IsamFileBlockPtr; + Var RefNr : LongInt; + Var Source ); + Begin + BTAddRec ( IFBPtr, RefNr, Source ); + End; + + Function UsedRecs ( IFBPtr : IsamFileBlockPtr ) : LongInt; + Begin + UsedRecs := BTUsedRecs ( IFBPtr ); + End; + + Function UsedKeys ( IFBPtr : IsamFileBlockPtr; Key : Integer ) : LongInt; + Begin + UsedKeys := BTUsedKeys ( IFBPtr, Key ); + End; + + Function FreeRecs ( IFBPtr : IsamFileBlockPtr ) : LongInt; + Begin + FreeRecs := BTFreeRecs ( IFBPtr ); + End; + + Function FileLen ( IFBPtr : IsamFileBlockPtr ) : LongInt; + Begin + FileLen := BTFileLen ( IFBPtr ); + End; + + Function DatNrOfKeys ( IFBPtr : IsamFileBlockPtr ) : Integer; + Begin + DatNrOfKeys := BTNrOfKeys ( IFBPtr ); + End; + + Function DatRecordSize ( IFBPtr : IsamFileBlockPtr ) : LongInt; + Begin + DatRecordSize := BTDatRecordSize ( IFBPtr ); + End; + + Function KeyRecordSize ( IFBPtr : IsamFileBlockPtr ) : LongInt; + Begin + KeyRecordSize := BTKeyRecordSize ( IFBPtr ); + End; + + Function MinimumDatKeys ( IFBPtr : IsamFileBlockPtr; Space : LongInt ) + : LongInt; + Begin + MinimumDatKeys := BTMinimumDatKeys ( IFBPtr, Space ); + End; + + Function MinSpaceForPageStack : LongInt; + Begin + IsamClearOK; + MinSpaceForPageStack := + LongInt (RoundToGranul ( SizeOf (IsamRingBufferRec) ) + + RoundToGranul ( SizeOf (IsamPageEntry) )) + * LongInt (MaxHeight); + End; + + Procedure DeleteRec ( IFBPtr : IsamFileBlockPtr; RefNr : LongInt ); + Begin + BTDeleteRec ( IFBPtr, RefNr ); + End; + + Function GetPageStack ( Free : LongInt ) : Integer; + Var + LResult : LongInt; {!!.51} + Net : NetSupportType; {!!} + Begin + if NetIsExpected then {!!} + Net := DynamicNetType {!!} + else {!!} + Net := NoNet; {!!} + LResult := BTInitIsam ( Net, Free, 0 ); {!!} {!!.51} + GetPageStack := ILI (LResult).Lo; {!!.51} + End; + + Procedure ReleasePageStack; + Begin + BTExitIsam; + End; + + Procedure FlushIsamBuffers; + Begin + BTFlushAllFileBlocks; + End; + + Procedure FlushAllFileBlocks; + Begin + BTFlushAllFileBlocks; + End; + + Procedure FlushBuffer ( IFBPtr : IsamFileBlockPtr ); + Begin + BTFlushFileBlock ( IFBPtr ); + End; + + Procedure FlushFileBlock ( IFBPtr : IsamFileBlockPtr ); + Begin + BTFlushFileBlock ( IFBPtr ); + End; + + Procedure MakeFileBlock ( Var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName; + DatSLen : LongInt; + NumberOfKeys : Integer; + IID : IsamIndDescr); + Begin + BTCreateFileBlock ( FName, DatSLen, NumberOfKeys, IID ); + If IsamOK Then Begin + BTOpenFileBlock ( IFBPtr, FName, False, False, False, False ); + End; + End; + + Procedure OpenFileBlock ( Var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName ); + Begin + BTOpenFileBlock ( IFBPtr, FName, False, False, False, False ); + End; + + Procedure OpenSaveFileBlock ( Var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName ); + Begin + BTOpenFileBlock ( IFBPtr, FName, False, False, True, False ); + End; + + Procedure CloseFileBlock ( Var IFBPtr : IsamFileBlockPtr ); + Begin + BTCloseFileBlock ( IFBPtr ); + End; + + Procedure CloseAllFileBlocks; + Begin + BTCloseAllFileBlocks; + End; + + Procedure DeleteFileBlock ( FName : IsamFileBlockName ); + Begin + BTDeleteFileBlock ( FName ); + End; + + Function FileBlockIsOpen ( IFBPtr : IsamFileBlockPtr ) : Boolean; + Begin + FileBlockIsOpen := BTFileBlockIsOpen ( IFBPtr ); + End; + + Procedure ClearKey ( IFBPtr : IsamFileBlockPtr; Key : Integer ); + Begin + BTClearKey ( IFBPtr, Key ); + End; + + Procedure NextKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + Begin + BTNextKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure PrevKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + Begin + BTPrevKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure FindKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + UserKey : IsamKeyStr ); + Begin + BTFindKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure SearchKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + Begin + BTSearchKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure FindKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr; + NotFoundSearchDirection : Integer ); + Begin + BTFindKeyAndRef ( IFBPtr, Key, UserDatRef, UserKey, + NotFoundSearchDirection ); + End; + + Procedure SearchKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + Begin + BTSearchKeyAndRef ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Function KeyExists ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + UserDatRef : LongInt; + UserKey : IsamKeyStr ) : Boolean; + Begin + KeyExists := BTKeyExists ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure NextDiffKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + Begin + BTNextDiffKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure PrevDiffKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + Begin + BTPrevDiffKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure AddKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + UserDatRef : LongInt; + UserKey : IsamKeyStr ); + Begin + BTAddKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure DeleteKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + UserDatRef : LongInt; + UserKey : IsamKeyStr ); + Begin + BTDeleteKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure DeleteAllKeys ( IFBPtr : IsamFileBlockPtr; + Key : Integer ); + Begin + BTDeleteAllKeys ( IFBPtr, Key ); + End; + + Procedure EnableSearchForSequential ( IFBPtr : IsamFileBlockPtr; + Key : Integer ); + Begin + BTSetSearchForSequential ( IFBPtr, Key, True ); + End; + + Procedure DisableSearchForSequential ( IFBPtr : IsamFileBlockPtr; + Key : Integer ); + Begin + BTSetSearchForSequential ( IFBPtr, Key, False ); + End; + + Procedure TestSearchForSequential ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var TSFS : Boolean ); + Begin + BTGetSearchForSequential ( IFBPtr, Key, TSFS ); + End; + + Procedure GetApprRelPos ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var RelPos : Word; + Scale : Word; + UserKey : IsamKeyStr; + UserDatRef : LongInt ); + Begin + BTGetApprRelPos ( IFBPtr, Key, RelPos, Scale, UserKey, UserDatRef ); + End; + + Procedure GetApprKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + RelPos : Word; + Scale : Word; + Var UserKey : IsamKeyStr; + Var UserDatRef : LongInt ); + Begin + BTGetApprKeyAndRef ( IFBPtr, Key, RelPos, Scale, UserKey, UserDatRef ); + End; + + procedure InitNetIsam(NetExpected : Boolean); {!!} + Begin + IsamClearOK; + NetIsExpected := NetExpected; {!!} + End; + + Procedure ExitNetIsam; + Begin + IsamClearOK; + NetIsExpected := False; {!!} + End; + + Procedure ReadLockFileBlock ( IFBPtr : IsamFileBlockPtr ); + Begin + BTReadLockFileBlock ( IFBPtr ); + End; + + Procedure LockFileBlock ( IFBPtr : IsamFileBlockPtr ); + Begin + BTLockFileBlock ( IFBPtr ); + End; + + Procedure UnLockFileBlock ( IFBPtr : IsamFileBlockPtr ); + Begin + BTUnLockFileBlock ( IFBPtr ); + End; + + Procedure ReadLockAllOpenFileBlocks; + Begin + BTReadLockAllOpenFileBlocks; + End; + + Procedure LockAllOpenFileBlocks; + Begin + BTLockAllOpenFileBlocks; + End; + + Procedure UnLockAllOpenFileBlocks; + Begin + BTUnLockAllOpenFileBlocks; + End; + + Procedure LockRec ( IFBPtr : IsamFileBlockPtr; Ref : LongInt ); + Begin + BTLockRec ( IFBPtr, Ref ); + End; + + Procedure UnLockRec ( IFBPtr : IsamFileBlockPtr; Ref : LongInt ); + Begin + BTUnLockRec ( IFBPtr, Ref ); + End; + + Procedure GetRecordInfo ( IFBPtr : IsamFileBlockPtr; + Ref : LongInt; + Var Start, Len : LongInt; + Var Handle : Word ); + Begin + BTGetRecordInfo ( IFBPtr, Ref, Start, Len, Handle ); + End; + + Function FileBlockIsLocked ( IFBPtr : IsamFileBlockPtr ) : Boolean; + Begin + FileBlockIsLocked := BTFileBlockIsLocked ( IFBPtr ); + End; + + Function FileBlockIsReadLocked ( IFBPtr : IsamFileBlockPtr ) : Boolean; + Begin + FileBlockIsReadLocked := BTFileBlockIsReadLocked ( IFBPtr ); + End; + + Function UsedNetRecs ( IFBPtr : IsamFileBlockPtr ) : LongInt; + Begin + UsedNetRecs := BTUsedRecs ( IFBPtr ); + End; + + Function UsedNetKeys ( IFBPtr : IsamFileBlockPtr; Key : Integer ) : LongInt; + Begin + UsedNetKeys := BTUsedKeys ( IFBPtr, Key ); + End; + + Function FreeNetRecs ( IFBPtr : IsamFileBlockPtr ) : LongInt; + Begin + FreeNetRecs := BTFreeRecs ( IFBPtr ); + End; + + Function NetFileLen ( IFBPtr : IsamFileBlockPtr ) : LongInt; + Begin + NetFileLen := BTFileLen ( IFBPtr ); + End; + + Procedure GetNetRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest ); + Begin + BTGetRec ( IFBPtr, RefNr, Dest, False ); + End; + + Procedure FindNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + UserKey : IsamKeyStr ); + Begin + BTFindKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure SearchNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + Begin + BTSearchKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure FindNetKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr; + NotFoundSearchDirection : Integer ); + Begin + BTFindKeyAndRef ( IFBPtr, Key, UserDatRef, UserKey, + NotFoundSearchDirection ); + End; + + Procedure SearchNetKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + Begin + BTSearchKeyAndRef ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Function NetKeyExists ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + UserDatRef : LongInt; + UserKey : IsamKeyStr ) : Boolean; + Begin + NetKeyExists := BTKeyExists ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure NextNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + Begin + BTNextKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure PrevNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + Begin + BTPrevKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure ClearNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer ); + Begin + BTClearKey ( IFBPtr, Key ); + End; + + Procedure NextDiffNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + Begin + BTNextDiffKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure PrevDiffNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var UserDatRef : LongInt; + Var UserKey : IsamKeyStr ); + Begin + BTPrevDiffKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure GetNetRecInSpiteOfLock ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest ); + Begin + BTGetRec ( IFBPtr, RefNr, Dest, True ); + End; + + Procedure GetNetRecReadOnly ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest ); + Begin + BTGetRecReadOnly ( IFBPtr, RefNr, Dest ); + End; + + + Procedure AddNetRec ( IFBPtr : IsamFileBlockPtr; + Var RefNr : LongInt; + Var Source ); + Begin + BTAddRec ( IFBPtr, RefNr, Source ); + End; + + Procedure PutNetRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Source ); + Begin + BTPutRec ( IFBPtr, RefNr, Source, False ); + End; + + Procedure DeleteNetRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt ); + Begin + BTDeleteRec ( IFBPtr, RefNr ); + End; + + Procedure AddNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + UserDatRef : LongInt; + UserKey : IsamKeyStr ); + Begin + BTAddKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure DeleteNetKey ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + UserDatRef : LongInt; + UserKey : IsamKeyStr ); + Begin + BTDeleteKey ( IFBPtr, Key, UserDatRef, UserKey ); + End; + + Procedure DeleteAllNetKeys ( IFBPtr : IsamFileBlockPtr; + Key : Integer ); + Begin + BTDeleteAllKeys ( IFBPtr, Key ); + End; + + Procedure PutNetRecInSpiteOfLock ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Source ); + Begin + BTPutRec ( IFBPtr, RefNr, Source, True ); + End; + + Procedure MakeNetFileBlock ( Var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName; + DatSLen : LongInt; + AnzKey : Integer; + IID : IsamIndDescr ); + Begin + BTCreateFileBlock ( FName, DatSLen, AnzKey, IID ); + If IsamOK Then Begin + BTOpenFileBlock ( IFBPtr, FName, False, False, False, True ); + End; + End; + + Procedure CloseNetFileBlock ( Var IFBPtr : IsamFileBlockPtr ); + Begin + BTCloseFileBlock ( IFBPtr ); + End; + + Procedure CloseEachFileBlock; + Begin + BTCloseAllFileBlocks; + End; + + Procedure OpenNetFileBlock ( Var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName ); + Begin + BTOpenFileBlock ( IFBPtr, FName, False, False, False, True ); + End; + + Procedure OpenSaveNetFileBlock ( Var IFBPtr : IsamFileBlockPtr; + FName : IsamFileBlockName ); + Begin + BTOpenFileBlock ( IFBPtr, FName, False, False, True, True ); + End; + + Procedure DeleteNetFileBlock ( FName : IsamFileBlockName ); + Begin + BTDeleteFileBlock ( FName ); + End; + + Function SetDosRetry ( NrOfRetries, WaitTime : Integer ) : Boolean; + Begin + SetDosRetry := BTSetDosRetry ( NrOfRetries, WaitTime ); + End; + + Function NetSupported : NetSupportType; + Begin + NetSupported := BTNetSupported; {!!} + End; + + Function NoNetCompiled : Boolean; + Begin + NoNetCompiled := BTNoNetCompiled; + End; + + Function IsNetFileBlock ( IFBPtr : IsamFileBlockPtr ) : Boolean; + Begin + IsNetFileBlock := BTIsNetFileBlock ( IFBPtr ); + End; + + Procedure GetApprNetRelPos ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + Var RelPos : Word; + Scale : Word; + UserKey : IsamKeyStr; + UserDatRef : LongInt ); + Begin + BTGetApprRelPos ( IFBPtr, Key, RelPos, Scale, UserKey, UserDatRef ); + End; + + Procedure GetApprNetKeyAndRef ( IFBPtr : IsamFileBlockPtr; + Key : Integer; + RelPos : Word; + Scale : Word; + Var UserKey : IsamKeyStr; + Var UserDatRef : LongInt ); + Begin + BTGetApprKeyAndRef ( IFBPtr, Key, RelPos, Scale, UserKey, UserDatRef ); + End; + + Procedure ForceNetBufferWriteThrough ( DoIt : Boolean ); + Begin + BTForceNetBufferWriteThrough ( DoIt ); + End; + + {!!} {Routines that were in FILER.PAS but not in German version} + + function FileBlockLocked(IFBPtr : IsamFileBlockPtr) : Boolean; + begin + FileBlockLocked := BTFileBlockIsLocked ( IFBPtr ); + end; + + function FileNameFromIFBPtr(IFBPtr : IsamFileBlockPtr) : IsamFileBlockName; + begin + FileNameFromIFBPtr := BTDataFileName(IFBPtr); + end; + + function PageStackValid(IFBPtr : IsamFileBlockPtr; KeyNr : Integer) : IsamPageStackState; + begin + if BTOtherWSChangedKey(IFBPtr, KeyNr) then + PageStackValid := StateInvalid + else + PageStackValid := StateValid; + end; + + procedure IsamFileSize(F : IsamFile; var Size : LongInt); + begin + IsamLongSeekEOF(F, Size); + end; + + procedure RemoveActiveLocks(IFBPtr : IsamFileBlockPtr); + begin + BTUnlockAllRecs(IFBPtr); + BTUnLockFileBlock(IFBPtr); + end; + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/isnetsup.inc b/src/wc_sdk/isnetsup.inc new file mode 100644 index 0000000..8c9924d --- /dev/null +++ b/src/wc_sdk/isnetsup.inc @@ -0,0 +1,527 @@ +{********************************************************************} +{* ISNETSUP.INC - network support routines *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{$IFDEF MSDOS} +type + IsamINT24HandlerDef = record + PushAXBX, + PushCXDX, + PushBPSI, + PushDIDS, + PushESF : Word; + AndDIFF1 : LongInt; + CmpDI02 : LongInt; + Jz1DoOldINT : Word; {!!.41 mod} + CmpDI09 : LongInt; {!!.41} + Jz2DoOldINT : Word; {!!.41} + MovAHExtErr : Word; + NopMovBX : Word; + Level : Word; + Int21 : Word; + JcDoOldINT : Word; + CmpBH, LockNop : Word; + JzMyTurn : Word; + Cmp1BH : Word; + InterLockNop : Word; + Jz1MyTurn : Word; +{ DoOldINT : } + PopFES1, + PopDSDI1, + PopSIBP1, + PopDXCX1, + PopBXAX1 : Word; + NopJmpFar : Word; + OldINT24Addr : Pointer; +{ MyTurn : } + NopMovAX : Word; + SegLockError : Word; + MovDSAX : Word; + MovByte : Word; + OfsLockError : Word; + ConstTrueNop : Word; + PopFES2, + PopDSDI2, + PopSIBP2, + PopDXCX2, + PopBXAX2 : Word; + MovALFail : Word; + IRetNop : Word; + end; + +const + IsamINT24Handler : IsamINT24HandlerDef = ( + PushAXBX : $5350; + PushCXDX : $5251; + PushBPSI : $5655; + PushDIDS : $1E57; + PushESF : $9C06; + AndDIFF1 : $00FFE781; + CmpDI02 : $0002FF81; + Jz1DoOldINT : $1674; {!!.41 mod} + CmpDI09 : $0009FF81; {!!.41} + Jz2DoOldINT : $1074; {!!.41} + MovAHExtErr: $59B4; + NopMovBX : $BB90; + Level : $0000; + Int21 : $21CD; + JcDoOldINT : $0672; + CmpBH : $FF80; + LockNop : $9002; + JzMyTurn : $1674; + Cmp1BH : $FF80; + InterLockNop : $900A; + Jz1MyTurn : $1074; + + PopFES1 : $079D; + PopDSDI1 : $5F1F; + PopSIBP1 : $5D5E; + PopDXCX1 : $595A; + PopBXAX1 : $585B; + NopJmpFar : $EA90; + OldINT24Addr : Nil; + + NopMovAX : $B890; + SegLockError : $FFFF; + MovDSAX : $D88E; + MovByte : $06C6; + OfsLockError : $FFFF; + ConstTrueNop : $9000; + PopFES2 : $079D; + PopDSDI2 : $5F1F; + PopSIBP2 : $5D5E; + PopDXCX2 : $595A; + PopBXAX2 : $585B; + MovALFail : $03B0; + IRetNop : $90CF); + + +procedure IsamInstallInt24Handler; +begin + with IsamINT24Handler do begin + CallGetIntVec($24, OldINT24Addr); + SegLockError := Seg (IsamLockError); + OfsLockError := Ofs (IsamLockError); + ConstTrueNop := ConstTrueNop + Ord (True); + end; + CallSetIntVec($24, @ IsamINT24Handler); +end; + + +procedure IsamRemoveInt24Handler; +begin + CallSetIntVec($24, IsamINT24Handler.OldINT24Addr); +end; +{$ENDIF} + + +{===NoNet network definition=========================================} +function NoNetLockRecord(Start, + Len : LongInt; + Handle : IsamHandle; + TimeOut, + DelayTime : Word) : Boolean; far; +begin + NoNetLockRecord := True; +end; +{--------} +function NoNetUnLockRecord(Start, + Len : LongInt; + Handle : IsamHandle) : Boolean; far; +begin + NoNetUnLockRecord := True; +end; +{--------} +function NoNetExitNet : Boolean; far; +begin + {$IFDEF MSDOS} + IsamRemoveInt24Handler; + {$ENDIF} + NoNetExitNet := True; +end; +{--------} +function NoNetInitNet : Boolean; +begin + IsamDefNrOfWS := 0; + {$IFDEF MSDOS} + IsamInstallInt24Handler; + {$ENDIF} + IsamLockRecord := NoNetLockRecord; + IsamUnLockRecord := NoNetUnLockRecord; + IsamExitNet := NoNetExitNet; + NoNetInitNet := True; +end; +{====================================================================} + + +{===Novell network definition========================================} +{$IFDEF Novell} +{$IFDEF SupportVLM} {!!.TP} +function NovellLockRecord(Start, + Len : LongInt; + Handle : IsamHandle; + TimeOut, + DelayTime : Word) : Boolean; far; +var + Status : word; + TimeCount : word; +begin + Status := nwLockRecord(Handle, Start, Len, TimeOut div 55); {!!.51} + if ((Lo(Status) = $FF) and (TimeOut <> 0)) then + begin + {-Call has failed without waiting for timeout; this occurs only + if a region is attempted to be locked which is already locked + by another task of the same machine; so give preemptive + multitasking a chance by reapeating the call with delays.} + TimeCount := DelayTime; + while (Status <> 0) and (TimeCount < TimeOut) do + begin + Status := nwLockRecord(Handle, Start, Len, 0); + inc(TimeCount, DelayTime); + if (Status <> 0) and (TimeCount < TimeOut) then + IsamDelay(DelayTime); + end; + end; + if (Status <> 0) and (IsamDOSError = 0) then + begin + if (nwShellType = nsVLM) then + IsamDOSFunc := $1A01 + else IsamDOSFunc := $BC01; + IsamDOSError := Status; + end; + NovellLockRecord := (Status = 0); +end; +{--------} +function NovellUnlockRecord(Start, + Len : LongInt; + Handle : IsamHandle) : Boolean; far; +var + Status : word; +begin + Status := nwUnlockRecord(Handle, Start, Len); + if (Status <> 0) then + begin + if (IsamDOSError = 0) then + begin + if (nwShellType = nsVLM) then + IsamDOSFunc := $1E00 + else IsamDOSFunc := $BE00; + IsamDOSError := Status; + end; + NovellUnlockRecord := False; + end + else + NovellUnlockRecord := True; +end; +{--------} +function NovellExitNet : Boolean; far; +begin + {$IFDEF MSDOS} + IsamRemoveInt24Handler; + {$ENDIF} + NovellExitNet := True; +end; +{$ELSE} +type + ILI = record Lo, Hi : word; end; +function NovellLockRecord(Start, + Len : LongInt; + Handle : IsamHandle; + TimeOut, + DelayTime : Word) : Boolean; far; +var + IRR : GenRegisters; + TimeCount : Word; +begin + DefaultRegisters(IRR); {!!.41} + with IRR do begin + BX := Handle; + CX := ILI(Start).Hi; + DX := ILI(Start).Lo; + SI := ILI(Len).Hi; + DI := ILI(Len).Lo; + BP := TimeOut Div 55; + AH := $BC; + AL := $01; + if IsamDOSError = 0 then + IsamDOSFunc := AX; + {$IFDEF DPMI} + CallDPMIRealModeIntr($21, IRR); + {$else} + CallMsDos(IRR); + {$ENDIF} + if IsamDOSError = 0 then + IsamDOSError := AL; + if (AL = $FF) and (TimeOut <> 0) then begin + {-Call is failed without waiting for timeout; this occurs only, if a + region is attempted to be locked, which is already locked by + another task of the same machine; so give preemptive multitasking + a chance by reapeating the call with delays} + TimeCount := DelayTime; + while (AL <> 0) and (TimeCount < TimeOut) do begin + DefaultRegisters(IRR); {!!.41} + BX := Handle; + CX := ILI(Start).Hi; + DX := ILI(Start).Lo; + SI := ILI(Len).Hi; + DI := ILI(Len).Lo; + BP := 0; {No timeout; it doesn't work anyway} + AH := $BC; + AL := $01; + if IsamDOSError = 0 then + IsamDOSFunc := AX; + {$IFDEF DPMI} + CallDPMIRealModeIntr($21, IRR); + {$else} + CallMsDos(IRR); + {$ENDIF} + if IsamDOSError = 0 then + IsamDOSError := AX; + Inc(TimeCount, DelayTime); + if (AL <> 0) and (TimeCount < TimeOut) then begin + IsamDelay(DelayTime); + end; + end; + end; + NovellLockRecord := AL = 0; + end; +end; +{--------} +function NovellUnLockRecord(Start, + Len : LongInt; + Handle : IsamHandle) : Boolean; far; +var + IRR : GenRegisters; +begin + DefaultRegisters(IRR); {!!.41} + with IRR do begin + BX := Handle; + CX := ILI (Start).Hi; + DX := ILI (Start).Lo; + SI := ILI (Len).Hi; {!!.41} + DI := ILI (Len).Lo; {!!.41} + AX := $BE00; + if IsamDOSError = 0 then + IsamDOSFunc := AX; + {$IFDEF DPMI} + CallDPMIRealModeIntr($21, IRR); + {$else} + CallMsDos(IRR); + {$ENDIF} + if IsamDOSError = 0 then + IsamDOSError := AL; + NovellUnLockRecord := AL = 0; + end; +end; +{--------} +function NovellExitNet : Boolean; far; +begin + {$IFDEF MSDOS} + IsamRemoveInt24Handler; + {$ENDIF} + NovellExitNet := True; +end; +{$ENDIF} +{--------} +function NovellInitNet : Boolean; + {------} + function NovellInstalled : Boolean; {!!.41} + {$IFDEF SupportVLM} {!!.TP} + begin + NovellInstalled := (nwShellType <> nsNone); + end; + {$else} + {----} + function ServerInfoAvailable : Boolean; + type + TRequestBuf = Record + BufLen : Word; + SubFunc : Byte; + end; + TServerInfo = Record + BufLen : Word; + ServerNameStartChar : Char; + NotUsedSpace : Array [1..127] Of Byte; + end; + var + RequestBufPtr : ^TRequestBuf; + ServerInfoPtr : ^TServerInfo; + IRR : GenRegisters; + RealModePtr, + ProtModePtr : Pointer; + begin + ServerInfoAvailable := False; + + if not CallAllocRealModeMem(SizeOf (TRequestBuf) + + SizeOf (TServerInfo), RealModePtr, ProtModePtr) then Exit; + + RequestBufPtr := ProtModePtr; + ServerInfoPtr := ProtModePtr; + Inc (Word (ServerInfoPtr), SizeOf (TRequestBuf)); + FillChar(ServerInfoPtr^, SizeOf (TServerInfo), 0); + with RequestBufPtr^ do begin + BufLen := 1; + SubFunc := $11; + end; + + ServerInfoPtr^.BufLen := SizeOf (TServerInfo) - 2; + + DefaultRegisters(IRR); + with IRR do begin + AX := $E300; + DS := LongInt (RealModePtr) Shr 16; + SI := LongInt (RealModePtr) and $FFFF; + ES := DS; + DI := SI + SizeOf (TRequestBuf); + end; + CallDPMIRealModeIntr($21, IRR); + + ServerInfoAvailable := ServerInfoPtr^.ServerNameStartChar <> #0; + + CallFreeRealModeMem(SizeOf (TRequestBuf) + + SizeOf (TServerInfo), ProtModePtr); + end; + {----} + begin + NovellInstalled := ServerInfoAvailable; + end; + {$ENDIF} + {------} +begin + NovellInitNet := False; {!!.41} + if TestNetExistance then begin {!!.41} + if not NovellInstalled then Exit; {!!.41} + end; {!!.41} + IsamDefNrOfWS := MaxNrOfWorkStations; + {$IFDEF MSDOS} + IsamInstallInt24Handler; + {$ENDIF} + IsamLockRecord := NovellLockRecord; + IsamUnLockRecord := NovellUnLockRecord; + IsamExitNet := NovellExitNet; + NovellInitNet := True; {!!.41} +end; +{$ENDIF} +{====================================================================} + + +{===MsNet network definition=========================================} +{$IFDEF MsNet} +function MsNetLockRecord(Start, + Len : LongInt; + Handle : IsamHandle; + TimeOut, + DelayTime : Word) : Boolean; far; +var + TimeCount : longint; + LockedIt : boolean; +begin + TimeCount := 0; + repeat + inc(TimeCount, DelayTime); + if not btfLockFile(Handle, Start, Len) then begin + SetIsamDOSError; + if (TimeCount < TimeOut) then + IsamDelay(DelayTime); + LockedIt := false; + end + else + LockedIt := true; + until LockedIt or (TimeCount >= TimeOut); + MsNetLockRecord := LockedIt; +end; +{--------} +function MsNetUnLockRecord(Start, + Len : LongInt; + Handle : IsamHandle) : Boolean; far; +begin + if not btfUnlockFile(Handle, Start, Len) then begin + SetIsamDOSError; + MsNetUnLockRecord := false; + end + else + MsNetUnLockRecord := true; +end; +{--------} +function MsNetExitNet : Boolean; far; +begin + {$IFDEF MSDOS} + IsamRemoveInt24Handler; + {$ENDIF} + MsNetExitNet := true; +end; +{--------} +function MsNetInitNet : Boolean; + {------} + function MSNetInstalled : boolean; + begin + MSNetInstalled := true; {check removed !!.53} + end; + {------} +begin + MsNetInitNet := False; + if TestNetExistance then + if not MSNetInstalled then + Exit; + IsamDefNrOfWS := MaxNrOfWorkStations; + IsamLockRecord := MsNetLockRecord; + IsamUnLockRecord := MsNetUnLockRecord; + IsamExitNet := MsNetExitNet; + MsNetInitNet := true; +end; +{$ENDIF} +{====================================================================} + + +{--Additional net interfaces insert here} + + +{====================================================================} +function IsamInitNet(ExpectedNet : NetSupportType) : Boolean; +begin + case ExpectedNet Of + NoNet : IsamInitNet := NoNetInitNet; + {$IFDEF Novell} + Novell : IsamInitNet := NovellInitNet; + {$ENDIF} + {$IFDEF MsNet} + MsNet : IsamInitNet := MsNetInitNet; + {$ENDIF} + else + IsamInitNet := False; + end; {Case} +end; + +function IsamDoneNet : Boolean; +begin + IsamDoneNet := IsamExitNet; +end; +{====================================================================} + diff --git a/src/wc_sdk/listfile.pas b/src/wc_sdk/listfile.pas new file mode 100755 index 0000000..3f2363f --- /dev/null +++ b/src/wc_sdk/listfile.pas @@ -0,0 +1,130 @@ +program ListFile; + +uses + QxIndex, + QxStub, + WcType, + WcGlobal, + WcFileDb, + WcUserDb, + WcMisc, + Filer; + + function InitFiler : Boolean; + begin + BtInitIsam(NetSupportType(MwConfig^.Network), MinimizeUseOfNormalHeap, 0); + InitFiler := IsamOk; + end; + + + function LoadMakeWild(var MwConfig : TMakewildRec) : Boolean; + var + F : File of TMakewildRec; + SaveFileMode : Word; + + begin + LoadMakewild := False; + Assign(F, 'MAKEWILD.DAT'); + SaveFileMode := FileMode; + FileMode := ShareMode; + Reset(F); + FileMode := SaveFileMode; + if IoResult <> 0 then + Exit; + Read(F, MwConfig); + LoadMakewild := IoResult = 0; + Close(F); + if IoResult = 0 then + {ignore}; + end; + + + function Register : Boolean; + begin + Register := False; + if not LoadMakeWild(MwConfig^) then + Exit; + if not InitFiler then + Exit; + OpenFile(NodeInfoFile, MwConfig^.NodeInfoPath+'NODEINFO.DAT', SizeOf(TMasterInfo)); + Register := True; + end; + + + procedure UnRegister; + begin + CloseFile(NodeInfoFile); + end; + +var + MatchStr, + FileKey, + UserKey : IsamKeyStr; + FileRef, + UserRef : LongInt; + FileInfo : TFileRec; + User : TUserRec; + +begin +{ + if not Register then + begin + WriteLn('Unable to register'); + Exit; + end; + + if not UserDB.Init then + begin + WriteLn('Could not init USERDB'); + Exit; + end; + +} + if not filedb^.Init(MwConfig^.FileDataBasePath+'ALLFILES') then + begin + WriteLn('Could not init FILEDB'); + Exit; + end; + + filedb^.ClearKey(FileAreaKey); + + filedb^.NextKey(FileAreaKey, FileRef, FileKey); + + if not IsamOk then + WriteLn('No Files Found In System'); + + while IsamOk do + begin + filedb^.GetRec(FileRef, FileInfo); + WriteLn('Found File : '+FileInfo.FileName); + if (FileInfo.UploaderID = 0) and (FileInfo.Uploader <> '') then + begin + UserKey := FileInfo.Uploader; + UserDB.SearchKey(UserNameKey, UserRef, UserKey); + + if IsamOk then + begin + UserDb.GetRec(UserRef, User); + WriteLn('Uploader: '+User.UserName); + end + else + WriteLn('Uploader: None Found'); + end + else + begin + UserKey := Long2Str(FileInfo.UploaderID); + if UserDB.FindKey(UserIdKey, UserRef, UserKey) then + begin + UserDb.GetRec(UserRef, User); + WriteLn('Uploader: '+User.UserName); + end + else + WriteLn('Uploader: None Found'); + end; + if IsamOk then ; + + filedb^.NextKey(FileAreaKey, FileRef, FileKey); + end; + + UnRegister; +end. \ No newline at end of file diff --git a/src/wc_sdk/lowbrows.pas b/src/wc_sdk/lowbrows.pas new file mode 100644 index 0000000..6aafdec --- /dev/null +++ b/src/wc_sdk/lowbrows.pas @@ -0,0 +1,393 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I brdefopt.inc} + {$F-,V-,B-,S-,I-,R-} + {$IFDEF CanAllowOverlays} + {$O+,F+} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-} + {$ENDIF} + + +Unit LowBrows; + +Interface + +Uses + BTBase, + BTIsBase, + Filer, {!!.TP} +{$IFDEF BRUseShell} + OPSBase, + OOPShell; +{$ENDIF} +{$IFDEF BRUseIsam} + VRec; {!!.TP} +{$ENDIF} + +Const + BRCurrentlyLocked = -1; + BRNoFilterResult = -2; + BRFilterError = -3; {!!.42} + BRUserStatStart = -10; + MaxCols = 128; + BRLMaxRows = 255; + MaxEltsPerRow = 8; + BRUnbreakedOpers = 63; + BRBreakDelay = 50; +{$IFDEF BRUseShell} + NoError = OPSBase.NoError; + DialogError = OPSBase.DialogError; + LockError = OPSBase.LockError; + GenMaxKeyLen = IFDMaxKeyLen; + GenMaxPosRef = IFDMaxPossibleRef; +{$ENDIF} +{$IFDEF BRUseIsam} + NoError = 0; + DialogError = 1; + LockError = 2; + GenMaxKeyLen = MaxKeyLen; + GenMaxPosRef = $7FFFFFFF; +{$ENDIF} + +Type + BRLRowEltString = String [MaxCols]; + PBRLRowEltString = ^BRLRowEltString; + RowString = BRLRowEltString; + BRLRowEltStrArr = Array [1..MaxEltsPerRow] Of BRLRowEltString; + GenKeyStr = String [GenMaxKeyLen]; + + RowRec = Record + {-Read only part} + IKS : GenKeyStr; + Ref : LongInt; + Status : Integer; + {-Internal use only} + RowModified : Boolean; + RowBuilt : Boolean; + {-To manipulate part} + Case Boolean Of + True : ( + Row : RowString; + ); + False : ( + RowElt : BRLRowEltStrArr; + ); + End; + + RowRecPtr = ^RowRec; + + BRBrowScreen = Array [1..BRLMaxRows] Of RowRecPtr; + + BRLBrowser = Object + VarRecMaxReadLen : Word; + KeyNr : Word; + {--The following fields are set by the constructor only} + DelayTimeOnGetRec : Word; + RetriesOnGetRec : Word; + {$IFDEF BRUseShell} + UsedDriver : IFDriverPtr; + SaveRecord : DStat; + {$ENDIF} + {$IFDEF BRUseIsam} + UsedFileBlock : IsamFileBlockPtr; + DataBuffer : Pointer; + VariableRecs : Boolean; + LastVarRecLen : Word; + {$ENDIF} + {--The following fields are private use only} + ReadLockOpersCount : Word; + NoReadLockCount : Word; + UseReadLock : Boolean; + BSAPtr : ^BRBrowScreen; + AllocNrOfEltsPerRow : Word; + AllocNrOfRows : Word; + + Constructor Init ( DrvOrFileBlockPtr : Pointer; + NumberOfEltsPerRow : Word; + NumberOfRows : Word; + DelayOnGetRec : Word; + RetrOnGetRec : Word; + Var DatS; + IsVarRec : Boolean ); + Destructor Done; virtual; + Procedure SetDefaults; + Function BrowserCallAllowed : Boolean; + + {--The following functions may be overwritten in descending objects} + Function PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; Virtual; + + {--The following functions have more privat nature, but may be overwritten in + descending objects} + Function BRSetReadLockUsage ( Var UseRL : Boolean ) : Integer; Virtual; + Function BRGetRec ( Var RR : RowRec; + AskUser, + ReadFull : Boolean ) : Integer; Virtual; + {$IFDEF BRUseShell} + Function BRGetRootRec ( RootDriverPtr : IFDriverPtr; + VarRecReadLen : Word; + UseSecond : Boolean ) : Integer; Virtual; + {$ENDIF} + Function BRNextKey ( Var RR : RowRec ) : Integer; Virtual; + Function BRPrevKey ( Var RR : RowRec ) : Integer; Virtual; + Function BRFindKeyAndRef ( Var RR : RowRec; + NFSD : Integer ) : Integer; Virtual; + Function BRFindKeyAndRefNoFilter ( Var RR : RowRec; + NFSD : Integer ) : Integer; + {!!.42} + Function BRDoReadLock : Integer; Virtual; + Function BRDoUnLock : Integer; Virtual; + + {--The following routines are internal use only} + Function KeyInBounds ( Var KeyStr : GenKeyStr ) : Boolean; Virtual; + {!!.41} + Function BRCallFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; + Function BRLDoReadLock : Integer; + Function BRLDoUnLock : Integer; + Function BRLLockDetected : Boolean; + Function BRLSaveStatus : Integer; Virtual; + Function BRLRestoreStatus : Integer; Virtual; + Function BRLAllocBrowScreen ( NumberOfEltsPerRow : Word; + NumberOfRows : Word ) : Boolean; + Procedure BRLDeAllocBrowScreen; + Function BRLGetApprKeyAndRef ( RelPos : Word; + Scale : Word; + Var UserKey : GenKeyStr; + Var UserDatRef : LongInt ) : Integer; + Function BRLGetApprRelPos ( Var RelPos : Word; + Scale : Word; + UserKey : GenKeyStr; + UserDatRef : LongInt ) : Integer; + Function BRLUsedKeys ( Var UK : LongInt ) : Integer; + Procedure PrivatSetDefaults; + End; + + +Implementation + + Constructor BRLBrowser.Init ( DrvOrFileBlockPtr : Pointer; + NumberOfEltsPerRow : Word; + NumberOfRows : Word; + DelayOnGetRec : Word; + RetrOnGetRec : Word; + Var DatS; + IsVarRec : Boolean ); + + Begin + PrivatSetDefaults; + {$IFDEF BRUseShell} + UsedDriver := IFDriverPtr (DrvOrFileBlockPtr); + UsedDriver^.IFDOpenFile; + If MaxErrorClass <> NoError Then Fail; + {$ENDIF} + {$IFDEF BRUseIsam} + UsedFileBlock := IsamFileBlockPtr (DrvOrFileBlockPtr); + VariableRecs := IsVarRec; + DataBuffer := @DatS; + {$ENDIF} + DelayTimeOnGetRec := DelayOnGetRec; + RetriesOnGetRec := RetrOnGetRec; + If Not BRLAllocBrowScreen ( NumberOfEltsPerRow, NumberOfRows ) + Then Fail; + End; + + + Destructor BRLBrowser.Done; + + Begin + BRLDeAllocBrowScreen; + End; + + + Procedure BRLBrowser.SetDefaults; + + Begin + PrivatSetDefaults; + End; + + + Procedure BRLBrowser.PrivatSetDefaults; + + Begin + {$IFDEF BRUseShell} + VarRecMaxReadLen := IFDMaxVariableRecLength; + {$ENDIF} + {$IFDEF BRUseIsam} + VarRecMaxReadLen := MaxVariableRecLength; + {$ENDIF} + KeyNr := 0; + NoReadLockCount := 0; + ReadLockOpersCount := 0; + End; + + + Function BRLBrowser.KeyInBounds ( Var KeyStr : GenKeyStr ) : Boolean; + {!!.41} + {-Must internally be overridden in a descending object} + Begin + KeyInBounds := True; + End; + + + Function BRLBrowser.BRCallFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; + + Var + LResult : Integer; {!!.51} + + Begin + RR.RowBuilt := False; + If Not KeyInBounds ( RR.IKS ) Then Begin {!!.41} + {-Avoid testing the filter condition, if the key is not in bounds} + BRCallFilter := DialogError; {!!.41} + Exit; {!!.41} + End; {!!.41} + LResult := PerformFilter ( RR, UseIt ); {!!.51} + If LResult = NoError Then Begin {!!.51} + Inc (ReadLockOpersCount); + If ReadLockOpersCount > BRUnbreakedOpers Then Begin + {-Give another station a chance to lock the fileblock} + ReadLockOpersCount := 0; + If UseReadLock And BRLLockDetected Then Begin + LResult := BRDoUnLock; {!!.51} + If LResult = NoError Then Begin {!!.51} + IsamDelay ( BRBreakDelay ); + LResult := BRDoReadLock; {!!.51} + End; + End; + End; + End; + BRCallFilter := LResult; {!!.51} + End; + + + Function BRLBrowser.BRLDoReadLock : Integer; + + Begin + ReadLockOpersCount := 0; + If BRLLockDetected Then Begin + Inc (NoReadLockCount); + BRLDoReadLock := NoError; + End Else Begin + BRLDoReadLock := BRDoReadLock; + End; + End; + + + Function BRLBrowser.BRLDoUnLock : Integer; + + Begin + If NoReadLockCount = 0 Then Begin + BRLDoUnLock := BRDoUnLock; + End Else Begin + Dec (NoReadLockCount); + BRLDoUnLock := NoError; + End; + End; + + + Function BRLBrowser.BRLAllocBrowScreen ( NumberOfEltsPerRow : Word; + NumberOfRows : Word ) + : Boolean; + + Var + I : Word; + RowRecSize : Word; + + + Procedure UnDo ( NrToDeAlloc : Word ); + + Var + I : Word; + + Begin + For I := NrToDeAlloc DownTo 1 Do Begin + FreeMem ( BSAPtr^ [I], RowRecSize ); + End; + FreeMem ( BSAPtr, SizeOf (Pointer) * NumberOfRows ); + End; + + + Begin + BRLAllocBrowScreen := False; + if not IsamGetMem ( BSAPtr, SizeOf (Pointer) * NumberOfRows ) then Exit; + RowRecSize := SizeOf (RowRec) + - (MaxEltsPerRow - NumberOfEltsPerRow) * SizeOf (BRLRowEltString); + For I := 1 To NumberOfRows Do Begin + If not IsamGetMem ( BSAPtr^ [I], RowRecSize ) Then Begin + UnDo ( Pred (I) ); + Exit; + End; + End; + AllocNrOfEltsPerRow := NumberOfEltsPerRow; + AllocNrOfRows := NumberOfRows; + BRLAllocBrowScreen := True; + End; + + + Procedure BRLBrowser.BRLDeAllocBrowScreen; + + Var + I : Word; + RowRecSize : Word; + + Begin + RowRecSize := SizeOf (RowRec) + - (MaxEltsPerRow - AllocNrOfEltsPerRow) * SizeOf (BRLRowEltString); + For I := AllocNrOfRows DownTo 1 Do Begin + FreeMem ( BSAPtr^ [I], RowRecSize ); + End; + FreeMem ( BSAPtr, SizeOf (Pointer) * AllocNrOfRows ); + BSAPtr := Nil; + End; + + + Function BRLBrowser.PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; + + Begin + UseIt := True; + PerformFilter := NoError; + End; + + +{$IFDEF BRUseShell} + {$I brlshell.inc} +{$ENDIF} +{$IFDEF BRUseIsam} + {$I brlisam.inc} +{$ENDIF} + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/medbrows.pas b/src/wc_sdk/medbrows.pas new file mode 100644 index 0000000..efb419c --- /dev/null +++ b/src/wc_sdk/medbrows.pas @@ -0,0 +1,1244 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I brdefopt.inc} + {$F-,V-,B-,S-,I-,R-} + {$IFDEF CanAllowOverlays} + {$O+,F+} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-} + {$ENDIF} + + +Unit MedBrows; + +Interface + +Uses + LowBrows; + +Type + BrowScreenState = Record + STCurRow : Word; + STNrOfRows : Word; + STLastRow : Word; + End; + + PBRMBrowser = ^BRMBrowser; + BRMBrowser = Object ( BRLBrowser ) + NrOfRows : Word; + NrOfEltsPerRow : Word; + DefNrOfRows : Word; + LowKey, + HighKey : GenKeyStr; + CurRow : Word; + SaveStatus : Boolean; + + Constructor Init ( DrvOrFileBlockPtr : Pointer; + NumberOfEltsPerRow : Word; + NumberOfRows : Word; + DelayOnGetRec : Word; + RetrOnGetRec : Word; + DefaultNrOfRows : Word; + LKey, + HKey : GenKeyStr; + SaveStat : Boolean; + Var DatS; + IsVarRec : Boolean ); + Destructor Done; virtual; + Procedure SetDefaults; + + Procedure GetBrowScreenState ( Var BST : BrowScreenState ); + Function BrowScreenStateChanged ( Var BST : BrowScreenState ) : Boolean; + + {--The following functions must be overwritten in descending objects} + Function BuildRow ( Var RR : RowRec ) : Integer; Virtual; + + {--The following functions may be overwritten in descending objects} + Function PreCompletePage : Integer; Virtual; + Function PostCompletePage : Integer; Virtual; + + {--The following routines must not be overwritten in descending objects} + Function CompleteThisPage ( Var Changed : Boolean; + StartRow, + EndRow : Word ) : Integer; Virtual; + Function BuildFirstPage ( Var Changed : Boolean ) : Integer; Virtual; + Function BuildLastPage ( Var Changed : Boolean ) : Integer; Virtual; + Function BuildNextPage ( Nr : Word; + Var Moved : Word; + CompletePage : Boolean; + ModifyCurRow : Word; + Var Changed : Boolean ) : Integer; Virtual; + Function BuildPrevPage ( Nr : Word; + Var Moved : Word; + CompletePage : Boolean; + ModifyCurRow : Word; + Var Changed : Boolean ) : Integer; Virtual; + Function BuildThisPage ( Var Changed : Boolean ) : Integer; Virtual; + + {--The following routines may be called from overridden routines} + Function ExpandPage ( NewNrOfRows : Word ) : Integer; + Function ShrinkPage ( NewNrOfRows : Word ) : Integer; + Function BuildNewPage ( NewKeyNr : Word; + NewKeyStr : GenKeyStr; + NewRef : LongInt; + NewCurRow : Word; + NewNrOfRows : Word; + Var Changed : Boolean ) : Integer; + Function GetLastRow : Word; {!!.41b} + Function GetFirstRow : Word; {!!.41b} + Procedure SetCurRow ( NewValue : Word ); + Function GetCurRow : Word; + Procedure SetNrOfRows ( NewValue : Word ); + Function GetNrOfRows : Word; + Function GetNrOfEltsPerRow : Word; + Function GetCurrentKeyStr : GenKeyStr; + Function GetCurrentDatRef : LongInt; + Function GetRowMatchingRec ( Var RR : RowRec; + AskUser, + ReadFull : Boolean; + Var Match : Boolean ) : Integer; + Function BuildBrowScreenRow ( Var RR : RowRec ) : Integer; + + {--The following routines are internal use only} + Procedure EmptyRowDescr ( Var RR : RowRec ); + Procedure EmptyRowElts ( Var RR : RowRec ); + Procedure EmptyBrowScreen ( Start : Word; + EmptyRow : Boolean ); + Procedure ResetRowModified ( Start : Word ); + Function KeyInBounds ( Var KeyStr : GenKeyStr ) : Boolean; Virtual; + {!!.41} + Procedure BoundForceKeyAndRef ( Var KeyStr : GenKeyStr; + Var Ref : LongInt ); + Procedure AdjustCurRow ( Var CR : Word; UseLastRow : Boolean ); + Procedure AdjustNrOfRows ( Var NOR : Word ); + Procedure CopyRowRec ( Var RRSource, RRDest : RowRec ); + Procedure CopyRowRecDescr ( Var RRSource, RRDest : RowRec ); + Procedure CopyRowRecDep ( Var RRSource, RRDest : RowRec ); + Procedure PlaceAtEnd ( Var RR : RowRec ); + Procedure PlaceAtTop ( Var RR : RowRec ); + Function RowEltModified ( Var RRMod, RROrg : RowRec ) : Boolean; + Procedure PrivatSetDefaults; + End; + + +Implementation + + Constructor BRMBrowser.Init ( DrvOrFileBlockPtr : Pointer; + NumberOfEltsPerRow : Word; + NumberOfRows : Word; + DelayOnGetRec : Word; + RetrOnGetRec : Word; + DefaultNrOfRows : Word; + LKey, + HKey : GenKeyStr; + SaveStat : Boolean; + Var DatS; + IsVarRec : Boolean ); + + Begin + If Not BRLBrowser.Init ( DrvOrFileBlockPtr, NumberOfEltsPerRow, + NumberOfRows, DelayOnGetRec, RetrOnGetRec, DatS, IsVarRec ) + Then Fail; + If BRSetReadLockUsage ( UseReadLock ) <> NoError Then Fail; + EmptyBrowScreen ( 1, True ); + DefNrOfRows := DefaultNrOfRows; + If (DefNrOfRows < 1) Or (DefNrOfRows > AllocNrOfRows) Then Begin + DefNrOfRows := AllocNrOfRows; + End; + LowKey := LKey; + HighKey := HKey; + SaveStatus := SaveStat; + PrivatSetDefaults; + End; + + + Destructor BRMBrowser.Done; + + Begin + BRLBrowser.Done; + End; + + + Procedure BRMBrowser.SetDefaults; + + Begin + BRLBrowser.SetDefaults; + PrivatSetDefaults; + End; + + + Procedure BRMBrowser.PrivatSetDefaults; + + Begin + NrOfRows := AllocNrOfRows; + NrOfEltsPerRow := AllocNrOfEltsPerRow; + CurRow := 1; + End; + + + Procedure BRMBrowser.GetBrowScreenState ( Var BST : BrowScreenState ); + + Begin + With BST Do Begin + STCurRow := CurRow; + STNrOfRows := NrOfRows; + STLastRow := GetLastRow; + End; + End; + + + Function BRMBrowser.BrowScreenStateChanged ( Var BST : BrowScreenState ) + : Boolean; + + Begin + BrowScreenStateChanged := True; + With BST Do Begin + If STCurRow <> GetCurRow Then Exit; + If STNrOfRows <> NrOfRows Then Exit; + If STLastRow <> GetLastRow Then Exit; + End; + BrowScreenStateChanged := False; + End; + + + Function BRMBrowser.PreCompletePage : Integer; + + Begin + PreCompletePage := NoError; + End; + + + Function BRMBrowser.PostCompletePage : Integer; + + Begin + PostCompletePage := NoError; + End; + + + Function BRMBrowser.GetLastRow : Word; + + Var + I : Word; + + Begin + I := NrOfRows; + While (I > 0) And (BSAPtr^ [I]^.Ref = 0) Do Begin + Dec (I); + End; + GetLastRow := I; + End; + + + Function BRMBrowser.GetFirstRow : Word; + + Var + I : Word; + + Begin + I := 1; + While (I <= NrOfRows) And (BSAPtr^ [I]^.Ref = 0) Do Begin + Inc (I); + End; + GetFirstRow := I; + End; + + + Procedure BRMBrowser.EmptyRowDescr ( Var RR : RowRec ); + + Begin + With RR Do Begin + IKS := ''; + Ref := 0; + Status := 0; + End; + End; + + + Procedure BRMBrowser.EmptyRowElts ( Var RR : RowRec ); + + Var + I : Word; + + Begin + With RR Do Begin + For I := 1 To AllocNrOfEltsPerRow Do Begin + RowElt [I] := ''; + End; + RowModified := False; + RowBuilt := False; + End; + End; + + + Procedure BRMBrowser.EmptyBrowScreen ( Start : Word; + EmptyRow : Boolean ); + + Var + I : Word; + + Begin + For I := Start To AllocNrOfRows Do Begin + If EmptyRow Then EmptyRowElts ( BSAPtr^ [I]^ ); + EmptyRowDescr ( BSAPtr^ [I]^ ); + End; + End; + + + Procedure BRMBrowser.ResetRowModified ( Start : Word ); + + Var + I : Word; + + Begin + For I := Start To AllocNrOfRows Do Begin + BSAPtr^ [I]^.RowModified := False; + End; + End; + + + Function BRMBrowser.KeyInBounds ( Var KeyStr : GenKeyStr ) : Boolean; + + Begin + KeyInBounds := False; + If KeyNr <> 0 Then Begin + If Copy ( KeyStr, 1, Length (LowKey) ) < LowKey Then Exit; + If Copy ( KeyStr, 1, Length (HighKey) ) > HighKey Then Exit; + End; + KeyInBounds := True; + End; + + + Procedure BRMBrowser.BoundForceKeyAndRef ( Var KeyStr : GenKeyStr; + Var Ref : LongInt ); + + Begin + If Not KeyInBounds ( KeyStr ) Then Begin + If Copy ( KeyStr, 1, Length (LowKey) ) < LowKey Then Begin + KeyStr := LowKey; + Ref := 0; + End Else Begin + KeyStr := HighKey; + While Length (KeyStr) < GenMaxKeyLen Do Begin + KeyStr := KeyStr + #255; + End; + Ref := GenMaxPosRef; + End; + End; + End; + + + Procedure BRMBrowser.AdjustCurRow ( Var CR : Word; UseLastRow : Boolean ); + + Begin + If CR < 1 Then Begin + CR := 1; + End Else Begin + If UseLastRow Then Begin + If CR > GetLastRow Then CR := GetLastRow; + If CR = 0 Then CR := 1; + End Else Begin + If CR > NrOfRows Then CR := NrOfRows; + End; + End; + End; + + + Procedure BRMBrowser.AdjustNrOfRows ( Var NOR : Word ); + + Begin + If (NOR < 1) Or (NOR > AllocNrOfRows) Then Begin + NOR := AllocNrOfRows; {!!.41} + End; + End; + + + Procedure BRMBrowser.SetCurRow ( NewValue : Word ); + + Begin + AdjustCurRow ( NewValue, True ); + CurRow := NewValue; + End; + + + Function BRMBrowser.GetCurRow : Word; + + Begin + GetCurRow := CurRow; + End; + + + Procedure BRMBrowser.SetNrOfRows ( NewValue : Word ); + + Begin + AdjustNrOfRows ( NewValue ); + NrOfRows := NewValue; + End; + + + Function BRMBrowser.GetNrOfRows : Word; + + Begin + GetNrOfRows := NrOfRows; + End; + + + Function BRMBrowser.GetNrOfEltsPerRow : Word; + + Begin + GetNrOfEltsPerRow := NrOfEltsPerRow; + End; + + + Procedure BRMBrowser.CopyRowRec ( Var RRSource, RRDest : RowRec ); + + Begin + Move ( RRSource, RRDest, SizeOf (RowRec) + - (MaxEltsPerRow - AllocNrOfEltsPerRow) * SizeOf (BRLRowEltString) ); + End; + + + Procedure BRMBrowser.CopyRowRecDescr ( Var RRSource, RRDest : RowRec ); + + Begin + With RRDest Do Begin + IKS := RRSource.IKS; + Ref := RRSource.Ref; + Status := RRSource.Status; + End; + End; + + + Procedure BRMBrowser.CopyRowRecDep ( Var RRSource, RRDest : RowRec ); + + Begin + If RRSource.RowBuilt Then Begin + If Not RowEltModified ( RRSource, RRDest ) + Then RRSource.RowModified := False; + CopyRowRec ( RRSource, RRDest ); + End Else Begin + CopyRowRecDescr ( RRSource, RRDest ); + End; + End; + + + Procedure BRMBrowser.PlaceAtEnd ( Var RR : RowRec ); + + Var + I : Word; + + Begin + I := GetLastRow; + If I < NrOfRows Then Begin + CopyRowRecDep ( RR, BSAPtr^ [Succ (I)]^ ); + End Else Begin + For I := 1 To Pred (NrOfRows) Do Begin + CopyRowRec ( BSAPtr^ [Succ (I)]^, BSAPtr^ [I]^ ); + End; + CopyRowRec ( RR, BSAPtr^ [NrOfRows]^ ); + End; + End; + + + Procedure BRMBrowser.PlaceAtTop ( Var RR : RowRec ); + + Var + I : Word; + + Begin + I := GetFirstRow; + If I > 1 Then Begin + CopyRowRecDep ( RR, BSAPtr^ [Pred (I)]^ ); + End Else Begin + For I := NrOfRows DownTo 2 Do Begin + CopyRowRec ( BSAPtr^ [Pred (I)]^, BSAPtr^ [I]^ ); + End; + CopyRowRec ( RR, BSAPtr^ [1]^ ); + End; + End; + + + Function BRMBrowser.RowEltModified ( Var RRMod, RROrg : RowRec ) : Boolean; + + Var + I : Word; + + Begin + RowEltModified := True; + For I := 1 To NrOfEltsPerRow Do Begin + If RRMod.RowElt [I] <> RROrg.RowElt [I] Then Exit; + End; + RowEltModified := False; + End; + + + Function BRMBrowser.CompleteThisPage ( Var Changed : Boolean; + StartRow, + EndRow : Word ) : Integer; + + Var + Dummy, + LResult : Integer; {!!.51} + + + Function CompleteaPage ( Var Changed : Boolean ) : Integer; + + Var + Dummy : Integer; + + + Function ErrorReturned ( Err : Integer ) : Boolean; + + Begin + CompleteaPage := Err; + If Err <> NoError Then Begin + ErrorReturned := True; + End Else Begin + ErrorReturned := False; + End; + End; + + + Function CompleteaPageInner : Integer; + + Var + LResult : Integer; {!!.51} + I : Word; + SaveRowRec : RowRec; + + + Begin + Changed := False; + For I := StartRow To EndRow Do Begin + With BSAPtr^ [I]^ Do Begin + If Ref > 0 Then Begin + {-Negative values may not be read} + If Not RowBuilt Then Begin + If Status > BRUserStatStart Then Begin + LResult := BRGetRec ( BSAPtr^ [I]^, False, False ); {!!.51} + {-Don't ask user on lock error; + read only varrecmaxreadlen bytes} + CompleteaPageInner := LResult; {!!.51} + If LResult > LockError Then Exit; {!!.51} + If LResult <> NoError Then Status := BRCurrentlyLocked; {!!.51} + End; + LResult := BuildBrowScreenRow ( BSAPtr^ [I]^ ); {!!.51} + {-Sets RowBuilt to True and RowModified accordingly} + CompleteaPageInner := LResult; {!!.51} + If LResult <> NoError Then Exit; {!!.51} + End; + RowBuilt := False; + Changed := Changed Or RowModified; + End Else Begin + EmptyRowElts ( SaveRowRec ); + BSAPtr^ [I]^.RowModified := + RowEltModified ( BSAPtr^ [I]^, SaveRowRec ); + If BSAPtr^ [I]^.RowModified Then Begin + EmptyRowElts ( BSAPtr^ [I]^ ); + EmptyRowDescr ( BSAPtr^ [I]^ ); + Changed := True; + End; + End; + End; + End; + ResetRowModified ( 1 ); + CompleteaPageInner := NoError; + End; + + + Begin + If UseReadLock Then Begin + If ErrorReturned ( BRLDoReadLock ) Then Begin + Exit; + End; + If ErrorReturned ( CompleteaPageInner ) Then Begin + Dummy := BRLDoUnLock; + Exit; + End; + If ErrorReturned ( BRLDoUnLock ) Then Exit; + End Else Begin + If ErrorReturned ( CompleteaPageInner ) Then Exit; + End; + End; + + + Begin + LResult := PreCompletePage; {!!.51} + If LResult <> NoError Then Begin {!!.51} + CompleteThisPage := LResult; {!!.51} + Exit; + End; + If SaveStatus Then Dummy := BRLSaveStatus; + LResult := CompleteaPage ( Changed ); {!!.51} + If SaveStatus Then Dummy := BRLRestoreStatus; + If LResult <> NoError Then Begin {!!.51} + CompleteThisPage := LResult; {!!.51} + Dummy := PostCompletePage; + Exit; + End; + CompleteThisPage := PostCompletePage; + End; + + + Function BRMBrowser.BuildFirstPage ( Var Changed : Boolean ) : Integer; + + Var + Dummy : Integer; + + + Function ErrorReturned ( Err : Integer ) : Boolean; + + Begin + BuildFirstPage := Err; + If Err <> NoError Then Begin + ErrorReturned := True; + End Else Begin + ErrorReturned := False; + End; + End; + + + Function BuildFirstPageInner : Integer; + + Var + I, + LResult : Integer; {!!.51} + TRec : RowRec; + + Begin + EmptyBrowScreen ( 1, False ); + CurRow := 1; + With TRec Do Begin + EmptyRowElts ( TRec ); + IKS := LowKey; + Ref := 0; + Status := 0; + End; + LResult := BRFindKeyAndRef ( TRec, 1 ); {!!.51} + BuildFirstPageInner := LResult; {!!.51} + If LResult <> NoError Then Exit; {!!.51} + If Not KeyInBounds ( TRec.IKS ) Then Begin + BuildFirstPageInner := DialogError; + Exit; + End; + I := 1; + While (I <= NrOfRows) And (KeyInBounds ( TRec.IKS )) + And (LResult = NoError) Do Begin {!!.51} + CopyRowRecDep ( TRec, BSAPtr^ [I]^ ); + EmptyRowElts ( TRec ); + Inc (I); + If I <= NrOfRows Then Begin + LResult := BRNextKey ( TRec ); {!!.51} + If LResult > DialogError Then Begin {!!.51} + BuildFirstPageInner := LResult; {!!.51} + Exit; + End; + End; + End; + If I <= NrOfRows Then EmptyBrowScreen ( I, True ); + BuildFirstPageInner := NoError; + End; + + + Begin + Changed := True; + If UseReadLock Then Begin + If ErrorReturned ( BRLDoReadLock ) Then Exit; + If ErrorReturned ( BuildFirstPageInner ) Then Begin + Dummy := BRLDoUnLock; + Exit; + End; + If ErrorReturned ( BRLDoUnLock ) Then Exit; + End Else Begin + If ErrorReturned ( BuildFirstPageInner ) Then Exit; + End; + If ErrorReturned ( CompleteThisPage ( Changed, 1, NrOfRows ) ) Then; + End; + + + Function BRMBrowser.BuildLastPage ( Var Changed : Boolean ) : Integer; + + Var + Dummy : Integer; + + + Function ErrorReturned ( Err : Integer ) : Boolean; + + Begin + BuildLastPage := Err; + If Err <> NoError Then Begin + ErrorReturned := True; + End Else Begin + ErrorReturned := False; + End; + End; + + + Function BuildLastPageInner : Integer; + + Var + I, + LResult : Integer; {!!.51} + FRow, + LRow : Word; + TRec : RowRec; + Stop : Boolean; + + Begin + LRow := GetLastRow; + If LRow = 0 Then Inc (LRow); + EmptyBrowScreen ( 1, False ); + With TRec Do Begin + EmptyRowElts ( TRec ); + IKS := HighKey; + While Length (IKS) < GenMaxKeyLen Do Begin + IKS := IKS + #255; + End; + Status := 0; + Ref := GenMaxPosRef; + LResult := BRFindKeyAndRef ( TRec, -1 ); {!!.51} + BuildLastPageInner := LResult; {!!.51} + If LResult <> NoError Then Exit; {!!.51} + If Not KeyInBounds ( IKS ) Then Begin + BuildLastPageInner := DialogError; + Exit; + End; + CopyRowRecDep ( TRec, BSAPtr^ [LRow]^ ); + I := Pred (NrOfRows); + Repeat + EmptyRowElts ( TRec ); + LResult := BRPrevKey ( TRec ); {!!.51} + If LResult > DialogError Then Begin {!!.51} + BuildLastPageInner := LResult; {!!.51} + Exit; + End; + Dec (I); + If (KeyInBounds ( IKS )) And (LResult = NoError) Then Begin {!!.51} + PlaceAtTop ( TRec ); + Stop := False; + End Else Begin + Stop := True; + End; + Until Stop Or (I = 0); + End; + FRow := GetFirstRow; + If FRow <> 1 Then Begin + LRow := GetLastRow; + For I := 1 To Succ (LRow - FRow) Do Begin + CopyRowRec ( BSAPtr^ [Pred (I + FRow)]^, BSAPtr^ [I]^ ); + End; + EmptyBrowScreen ( LRow - FRow + 2, False ); + End; + BuildLastPageInner := NoError; + CurRow := GetLastRow; + End; + + + Begin + If UseReadLock Then Begin + If ErrorReturned ( BRLDoReadLock ) Then Exit; + If ErrorReturned ( BuildLastPageInner ) Then Begin + Dummy := BRLDoUnLock; + Exit; + End; + If ErrorReturned ( BRLDoUnLock ) Then Exit; + End Else Begin + If ErrorReturned ( BuildLastPageInner ) Then Exit; + End; + If ErrorReturned ( CompleteThisPage ( Changed, 1, NrOfRows ) ) Then; + End; + + + Function BRMBrowser.BuildNextPage ( Nr : Word; + Var Moved : Word; + CompletePage : Boolean; + ModifyCurRow : Word; + Var Changed : Boolean ) : Integer; + + Var + Dummy : Integer; + + + Function ErrorReturned ( Err : Integer ) : Boolean; + + Begin + BuildNextPage := Err; + If Err <> NoError Then Begin + ErrorReturned := True; + End Else Begin + ErrorReturned := False; + End; + End; + + + Function BuildNextPageInner : Integer; + + Var + I, + LResult : Integer; {!!.51} + TRec : RowRec; + + Begin + Moved := 0; + I := GetLastRow; + If I = 0 Then Begin + BuildNextPageInner := DialogError; + Exit; + End; + CopyRowRec ( BSAPtr^ [I]^, TRec ); + EmptyRowElts ( TRec ); + With TRec Do Begin + Status := 0; + LResult := BRFindKeyAndRef ( TRec, 0 ); {!!.51} + If LResult > DialogError Then Begin {!!.51} + BuildNextPageInner := LResult; {!!.51} + Exit; + End; + LResult := BRNextKey ( TRec ); {!!.51} + If LResult > DialogError Then Begin {!!.51} + BuildNextPageInner := LResult; {!!.51} + Exit; + End; + I := 1; + While (I <= Nr) And (KeyInBounds ( IKS )) + And (LResult = NoError) Do Begin {!!.51} + PlaceAtEnd ( TRec ); + EmptyRowElts ( TRec ); + Inc (I); + If I <= Nr Then Begin + LResult := BRNextKey ( TRec ); {!!.51} + If LResult > DialogError Then Begin {!!.51} + BuildNextPageInner := LResult; {!!.51} + Exit; + End; + End; + End; + End; + Moved := Pred (I); + If ModifyCurRow > 0 Then Begin + If Moved = 0 Then Begin + CurRow := GetLastRow; + End Else Begin + If ModifyCurRow > 1 Then Begin + CurRow := Succ (GetLastRow) - Moved; + End; + End; + End; + BuildNextPageInner := NoError; + End; + + + Begin + Changed := True; + If UseReadLock Then Begin + If ErrorReturned ( BRLDoReadLock ) Then Exit; + If ErrorReturned ( BuildNextPageInner ) Then Begin + Dummy := BRLDoUnLock; + Exit; + End; + If ErrorReturned ( BRLDoUnLock ) Then Exit; + End Else Begin + If ErrorReturned ( BuildNextPageInner ) Then Exit; + End; + If CompletePage Then Begin + If ErrorReturned ( CompleteThisPage ( Changed, + Succ (GetLastRow - Moved), NrOfRows ) ) Then; + End; + End; + + + Function BRMBrowser.BuildPrevPage ( Nr : Word; + Var Moved : Word; + CompletePage : Boolean; + ModifyCurRow : Word; + Var Changed : Boolean ) : Integer; + + + Var + Dummy : Integer; + + + Function ErrorReturned ( Err : Integer ) : Boolean; + + Begin + BuildPrevPage := Err; + If Err <> NoError Then Begin + ErrorReturned := True; + End Else Begin + ErrorReturned := False; + End; + End; + + + Function BuildPrevPageInner : Integer; + + Var + I, + LResult : Integer; {!!.51} + TRec : RowRec; + + Begin + I := GetFirstRow; + If I > NrOfRows Then Begin + BuildPrevPageInner := DialogError; + Exit; + End; + CopyRowRec ( BSAPtr^ [I]^, TRec ); + EmptyRowElts ( TRec ); + With TRec Do Begin + Status := 0; + LResult := BRFindKeyAndRef ( TRec, -1 ); {!!.51} + If LResult = NoError Then Begin {!!.51} + If (BSAPtr^ [I]^.Ref = TRec.Ref) + And (BSAPtr^ [I]^.IKS = TRec.IKS) Then Begin + {-Did we find the same key again?} + LResult := BRPrevKey ( TRec ); {!!.51} + End; + End; + If LResult > DialogError Then Begin {!!.51} + BuildPrevPageInner := LResult; {!!.51} + Exit; + End; + I := 1; + While (I <= Nr) And (KeyInBounds ( IKS )) + And (LResult = NoError) Do Begin {!!.51} + PlaceAtTop ( TRec ); + EmptyRowElts ( TRec ); + Inc (I); + If I <= Nr Then Begin + LResult := BRPrevKey ( TRec ); {!!.51} + If LResult > DialogError Then Begin {!!.51} + BuildPrevPageInner := LResult; {!!.51} + Exit; + End; + End; + End; + End; + Moved := Pred (I); + If ModifyCurRow > 0 Then Begin + If Moved = 0 Then Begin + CurRow := 1; + End Else Begin + If ModifyCurRow > 1 Then Begin + CurRow := Moved; + End; + End; + End; + BuildPrevPageInner := NoError; + End; + + + Begin + Changed := True; + If UseReadLock Then Begin + If ErrorReturned ( BRLDoReadLock ) Then Exit; + If ErrorReturned ( BuildPrevPageInner ) Then Begin + Dummy := BRLDoUnLock; + Exit; + End; + If ErrorReturned ( BRLDoUnLock ) Then Exit; + End Else Begin + If ErrorReturned ( BuildPrevPageInner ) Then Exit; + End; + If CompletePage Then Begin + If ErrorReturned ( CompleteThisPage ( Changed, 1, Moved ) ) Then; + End; + End; + + + Function BRMBrowser.BuildThisPage ( Var Changed : Boolean ) : Integer; + + + Function ErrorReturned ( Err : Integer ) : Boolean; + + Begin + BuildThisPage := Err; + If Err <> NoError Then Begin + ErrorReturned := True; + End Else Begin + ErrorReturned := False; + End; + End; + + + Function BuildThisPageInner : Integer; + + Var + I, + LResult : Integer; {!!.51} + Added : Word; + SaveRow : Word; + LRow, + FRow : Word; + TRec : RowRec; + Dummy : Boolean; + TooLessBehind : Boolean; + + + Begin + SaveRow := CurRow; + CopyRowRec ( BSAPtr^ [CurRow]^, TRec ); + EmptyBrowScreen ( 1, False ); + With TRec Do Begin + Status := 0; + LResult := BRFindKeyAndRef ( TRec, 0 ); {!!.51} + If LResult > DialogError Then Begin {!!.51} + BuildThisPageInner := LResult; {!!.51} + Exit; + End; + If LResult = DialogError Then Begin {!!.51} + LResult := BRNextKey ( TRec ); {!!.51} + If LResult > DialogError Then Begin {!!.51} + BuildThisPageInner := LResult; {!!.51} + Exit; + End; + If (LResult = DialogError) Or (Not KeyInBounds ( IKS )) Then Begin {!!.51} + LResult := BRPrevKey ( TRec ); {!!.51} + If LResult > DialogError Then Begin {!!.51} + BuildThisPageInner := LResult; {!!.51} + Exit; + End; + If (LResult = DialogError) Or (Not KeyInBounds ( IKS )) {!!.51} + Then Begin + EmptyBrowScreen ( 1, True ); + CurRow := 1; + BuildThisPageInner := DialogError; + Exit; + End; + End; + End; + End; + CopyRowRec ( TRec, BSAPtr^ [CurRow]^ ); + LResult := BuildNextPage ( NrOfRows - CurRow, Added, False, 0, Dummy ); {!!.51} + If LResult > DialogError Then Begin {!!.51} + BuildThisPageInner := LResult; {!!.51} + Exit; + End; + TooLessBehind := NrOfRows - CurRow <> Added; + If (CurRow <> 1) Or TooLessBehind Then Begin + LResult := BuildPrevPage ( NrOfRows - Succ (Added), Added, False, 0, {!!.51} + Dummy ); + If LResult > DialogError Then Begin {!!.51} + BuildThisPageInner := LResult; {!!.51} + Exit; + End; + CurRow := Succ (Added); + End; + If (Not TooLessBehind) And (SaveRow <> CurRow) Then Begin + LResult := BuildNextPage ( Pred (GetFirstRow), Added, False, 0, {!!.51} + Dummy ); + If LResult > DialogError Then Begin {!!.51} + BuildThisPageInner := LResult; {!!.51} + Exit; + End; + End; + + FRow := GetFirstRow; + LRow := GetLastRow; + If FRow <> 1 Then Begin + For I := 1 To Succ (LRow - FRow) Do Begin + CopyRowRec ( BSAPtr^ [Pred (I + FRow)]^, BSAPtr^ [I]^ ); + End; + EmptyBrowScreen ( LRow - FRow + 2, False ); + End Else Begin + If LRow < NrOfRows Then Begin + EmptyBrowScreen ( Succ (LRow), False ); + End; + End; + BuildThisPageInner := NoError; + End; + + + Begin + Changed := True; + If ErrorReturned ( BuildThisPageInner ) Then Exit; + If ErrorReturned ( CompleteThisPage ( Changed, 1, NrOfRows ) ) Then; + End; + + + Function BRMBrowser.ExpandPage ( NewNrOfRows : Word ) : Integer; + + Var + Dummy : Boolean; + ToAdd, + Added : Word; + LResult : Integer; {!!.51} + + Begin + ExpandPage := NoError; + If NewNrOfRows > AllocNrOfRows Then Exit; + NrOfRows := NewNrOfRows; + ToAdd := NrOfRows - GetLastRow; + LResult := BuildNextPage ( ToAdd, Added, True, 0, Dummy ); {!!.51} + ExpandPage := LResult; {!!.51} + If LResult <> NoError Then Exit; {!!.51} + If Added < ToAdd Then Begin + LResult := BuildPrevPage ( ToAdd - Added, Added, True, 0, Dummy ); {!!.51} + ExpandPage := LResult; {!!.51} + If LResult <> NoError Then Exit; {!!.51} + Inc (CurRow, Added); + End; + End; + + + Function BRMBrowser.ShrinkPage ( NewNrOfRows : Word ) : Integer; + + Var + RemoveAtTop : Word; + RemoveAtBottom : Word; + I : Word; + TPtr : RowRecPtr; + + Begin + ShrinkPage := NoError; + If NewNrOfRows = 0 Then Exit; + If NewNrOfRows < CurRow Then Begin + RemoveAtBottom := NrOfRows - CurRow; + RemoveAtTop := NrOfRows - NewNrOfRows - RemoveAtBottom; + End Else Begin + RemoveAtTop := 0; + RemoveAtBottom := NrOfRows - NewNrOfRows; + End; + NrOfRows := NewNrOfRows; + If RemoveAtTop > 0 Then Begin + Dec (CurRow, RemoveAtTop); + For I := 1 To NrOfRows Do Begin + TPtr := BSAPtr^ [I]; + BSAPtr^ [I] := BSAPtr^ [I + RemoveAtTop]; + BSAPtr^ [I + RemoveAtTop] := TPtr; + End; + End; + EmptyBrowScreen ( Succ (NrOfRows), True ); + End; + + + Function BRMBrowser.BuildNewPage ( NewKeyNr : Word; + NewKeyStr : GenKeyStr; + NewRef : LongInt; + NewCurRow : Word; + NewNrOfRows : Word; + Var Changed : Boolean ) : Integer; + + Begin + Changed := False; + BuildNewPage := NoError; + If NewNrOfRows > AllocNrOfRows Then Exit; + NrOfRows := NewNrOfRows; + AdjustCurRow ( NewCurRow, False ); + CurRow := NewCurRow; + KeyNr := NewKeyNr; + BoundForceKeyAndRef ( NewKeyStr, NewRef ); + With BSAPtr^ [CurRow]^ Do Begin + Ref := NewRef; + IKS := NewKeyStr; + End; + BuildNewPage := BuildThisPage ( Changed ); + End; + + + Function BRMBrowser.GetCurrentKeyStr : GenKeyStr; + + Begin + If (CurRow <= GetLastRow) And (CurRow > 0) Then Begin + GetCurrentKeyStr := BSAPtr^ [CurRow]^.IKS; + End Else Begin + GetCurrentKeyStr := ''; + End; + End; + + + Function BRMBrowser.GetCurrentDatRef : LongInt; + + Begin + If (CurRow <= GetLastRow) And (CurRow > 0) Then Begin + GetCurrentDatRef := BSAPtr^ [CurRow]^.Ref; + End Else Begin + GetCurrentDatRef := 0; + End; + End; + + + Function BRMBrowser.BuildRow ( Var RR : RowRec ) : Integer; + + Begin + RunError (211); + End; + + + Function BRMBrowser.GetRowMatchingRec ( Var RR : RowRec; + AskUser, + ReadFull : Boolean; + Var Match : Boolean ) + : Integer; + + Var + TRowRec : RowRec; + + + Function ErrorReturned ( Err : Integer ) : Boolean; + + Begin + GetRowMatchingRec := Err; + If Err <> NoError Then Begin + ErrorReturned := True; + End Else Begin + ErrorReturned := False; + End; + End; + + + Begin + Match := False; + If ErrorReturned (BRGetRec ( RR, AskUser, ReadFull )) Then Exit; + CopyRowRec ( RR, TRowRec ); + If ErrorReturned (BuildRow ( TRowRec )) Then Exit; + Match := Not RowEltModified ( TRowRec, RR ); + End; + + + Function BRMBrowser.BuildBrowScreenRow ( Var RR : RowRec ) : Integer; + + Var + LResult : Integer; {!!.51} + SaveRowRec : RowRec; + + Begin + CopyRowRec ( RR, SaveRowRec ); + LResult := BuildRow ( RR ); {!!.51} + BuildBrowScreenRow := LResult; {!!.51} + If LResult <> NoError Then Exit; {!!.51} + RR.RowModified := RowEltModified ( RR, SaveRowRec ); + RR.RowBuilt := True; + End; + + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/msgcheck.pas b/src/wc_sdk/msgcheck.pas new file mode 100755 index 0000000..3c686a2 --- /dev/null +++ b/src/wc_sdk/msgcheck.pas @@ -0,0 +1,88 @@ +program MsgCheck; + +uses + Crt, + QxIndex, + QxStub, + WcType, + WcGlobal, + WcFileDb, + WcUserDb, + WcMsgDb, + WcMisc, + Filer; + + function InitFiler : Boolean; + begin + BtInitIsam(NetSupportType(MwConfig.Network), MinimizeUseOfNormalHeap, 0); + InitFiler := IsamOk; + end; + + function LoadMakeWild(var MwConfig : TMakewildRec) : Boolean; + var + F : File of TMakewildRec; + SaveFileMode : Word; + + begin + LoadMakewild := False; + Assign(F, 'MAKEWILD.DAT'); + SaveFileMode := FileMode; + FileMode := ShareMode; + Reset(F); + FileMode := SaveFileMode; + if IoResult <> 0 then + Exit; + Read(F, MwConfig); + LoadMakewild := IoResult = 0; + Close(F); + if IoResult = 0 then + {ignore}; + end; + + + function Register : Boolean; + begin + Register := False; + if not LoadMakeWild(MwConfig) then + Exit; + if not InitFiler then + Exit; + OpenFile(NodeInfoFile, MwConfig.NodeInfoPath+'NODEINFO.DAT', SizeOf(TMasterInfo)); + Register := True; + end; + + + procedure UnRegister; + begin + CloseFile(NodeInfoFile); + end; + +var + X : Word; + MsgStats : TMsgStatus; + Conf : TConfDesc; + +begin + MsgDb.Init; {Must do this to start the message databases} + + if not Register then + begin + WriteLn('Unable to register'); + Exit; + end; + Writeln('Conferences that should be renumbered:'); + for x := 1 to MwConfig.MaxConfAreas do + if LoadConfDesc(Conf, x) and (Conf.Confname <> '') then + if MsgDB.Open(x, False) then + begin + Write(Pad(Long2Str(x),5),' ',Pad(Conf.Confname,25),' High Msg - ',MsgStats.HighMsg); + ClrEol; + MsgDB.GetMsgStatus(MsgStats); + If MsgStats.HighMsg > 60000 then + Writeln + else + Gotoxy(1,WhereY); + MsgDB.Done; + end; + UnRegister; +end. diff --git a/src/wc_sdk/msgimprt.pas b/src/wc_sdk/msgimprt.pas new file mode 100755 index 0000000..812653b --- /dev/null +++ b/src/wc_sdk/msgimprt.pas @@ -0,0 +1,230 @@ +program MsgImprt; + +(* + +This sample program imports data from a text file into the message database. +The command line format is: + + MSGIMPRT ConfNumber FileName + +For example, + + MSGIMPRT 0 test.txt + +The format of the text file is: + + (to name) + (from name) + (subject) + (private flag) + message text line 1.. + message text line 2.. + -END- + ..etc.. + +For example, + + JOE USER + THE SYSOP + Message Subject + PRIVATE + This is a private message from the sysop to Joe User. + This is the last line of this message. + -END- + ALL + JOE USER + Test public message + PUBLIC + This is a public message from Joe User to everybody. + -END- + +*) + +uses Filer, + WcMisc, + WcType, + WcUserDb, + WcMsgDb, + WcMsgEx; + +var f: Text; + conf: Longint; + ref: Longint; + Msg: TMsgHeader; + MsgText: PMsgText; + Fakeit: Boolean; + ExMsgDb: TExMsgBase; + + InputBuffer: array [1..16384] of Byte; + + function MultipleNames(const Name : String; var Found : LongInt) : Boolean; + var + Match, + KeyName : IsamKeyStr; + Records, + RefNr : LongInt; + + begin + MultipleNames := False; + Records := 0; + KeyName := BuildUserNameKey(Name, 0); + Match := Trim(Copy(KeyName, 1, 25)); + UserDB.SearchKey(UserNameKey, RefNr, KeyName); + + while IsamOk and (Match = Trim(Copy(KeyName, 1, 25))) do + begin + Inc(Records); + UserDB.NextKey(UserNameKey, RefNr, KeyName); + end; + + Found := Records; + + if (Records > 1) then + MultipleNames := True; + end; + + function UserInDataBase(const Name : String; var RefNr : LongInt) : Boolean; + var + TempStr, + KeyStr : IsamKeyStr; + IdName, + Found : LongInt; + + begin + UserInDataBase := False; + + KeyStr := BuildUserNameKey(Name, 0); + TempStr := Trim(Copy(KeyStr, 1, 25)); + UserDB.SearchKey(UserNameKey, RefNr, KeyStr); + KeyStr := Trim(Copy(KeyStr, 1, 25)); + + if KeyStr <> TempStr then + IsamOk := False; + + if IsamOK then + begin + if MultipleNames(Name, Found) then + Exit; + UserInDataBase := True; + Exit; + end; + + if Str2Long(Name, IdName) then + begin + KeyStr := BuildUserIDKey(IdName); + + if UserDB.FindKey(UserIdKey, RefNr, KeyStr) then + begin + UserInDataBase := True; + end; + end; + end; + + function GetUserIdNumber(const Name : String; var ID : LongInt) : Boolean; + var + RefNr : LongInt; + TRec : TuserRec; + + begin + GetUserIDNumber := False; + if not UserInDataBase(Name, RefNr) then + Exit; + UserDb.GetRec(RefNr, TRec); + ID := TRec.UserID; + GetUserIdNumber := True; + end; + +procedure ImportMessages; + +var s: String; + index: Word; + inserted: Word; + x: LOngint; + +begin + inserted := 0; + while not eof(f) do begin + FillChar(Msg, SIZEOF(TMsgHeader), 0); + ReadLn(f,Msg.Dest); + if Msg.Dest = '' then Msg.Dest := 'BLANK'; + Msg.Dest := StUpcase(Msg.Dest); + ReadLn(f,Msg.Orig); + if Msg.Orig = '' then Msg.Orig := 'BLANK'; + Msg.Orig := StUpcase(Msg.Orig); + ReadLn(f,Msg.Subject); + SetDateTime(Msg.MsgTime); + ReadLn(f,s); + s := Trim(s); + if s = 'PRIVATE' then + SetFlag(Msg.mFlags, mfPrivate); + index := 0; + ReadLn(f,s); + while not eof(f) and (s <> '-END-') do begin + if Length(s) > 79 then + s[0] := #79; + Move(s[1], MsgText^[index], Length(s)); + INC(index,Length(s)); + MsgText^[index] := #13; + Inc(index); + ReadLn(f,s); + end; + Msg.MsgBytes := index; + GetUserIdNumber(Msg.Dest, Msg.DestUserId); + if Fakeit then + ExMsgDb.AddMsg(Msg, MsgText, conf) + else + MsgDb.AddMsg(ref, Msg, MsgText); + Inc(inserted); + end; +end; + +var io: Integer; + +begin + if ParamCount < 2 then begin + WriteLn('MSGIMPRT Copyright (c) 1994 Mustang Software, Inc. Version 4.0'); + WriteLn; + WriteLn('Usage: MSGIMPRT ConfNumber FileName'); + Halt(1); + end; + + if not UserDB.Init then begin + WriteLn('Could not open user database'); + Halt; + end; + + GetMem(MsgText, 65520); + if MsgText = nil then begin + WriteLn('Insufficient memory for message buffer'); + Halt; + end; + + if not Str2Long(ParamStr(1), conf) then begin + WriteLn('Invalid conference number: '+ParamStr(1)); + Halt; + end; + Fakeit := False; + MsgDb.Init; + if not MsgDb.Open(conf, False) then begin + ExMsgDb.Init; + Fakeit := True; + end; + + Assign(f, ParamStr(2)); + Reset(f); + io := IoResult; + if io <> 0 then begin + WriteLn(5, 'Unable to open '+ParamStr(2)+', error code '+Long2Str(io)); + Halt; + end; + SetTextBuf(f, InputBuffer); + + ImportMessages; + + Close(f); + if Fakeit then + ExMsgDb.Done + else + MsgDb.Done; + UserDb.Done; +end. diff --git a/src/wc_sdk/msort.pas b/src/wc_sdk/msort.pas new file mode 100644 index 0000000..441973c --- /dev/null +++ b/src/wc_sdk/msort.pas @@ -0,0 +1,1402 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$F+,V-,B-,S-,I-,R-} + {$IFDEF CanAllowOverlays} + {$O+} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-,T-} {!!.41} + {$ENDIF} + +{$IFDEF DPMIOrWnd} {!!.41} + !! Error: this unit is for DOS real mode only +{$ENDIF} {!!.41} + +{!!.41 All Windows and DPMI support code removed} + +{Controls whether heap blocks larger than 64K are allocated. See the manual + for a discussion} +{.$DEFINE BigHeap} + +Unit Msort; + +interface +uses + DOS, + TPAlloc, +{$IFDEF UseOPEMS} + OPEMS; +{$ELSE} + {$IFDEF UseTPEMS} + TPEMS; + {$ELSE} + EMSSupp; + {$ENDIF} +{$ENDIF} + +const + MERGEORDER = 5; {The maximum number of input files for merge} + BiggestDataItem = 65521; {largest data item Turbo Pascal can handle} + UseEMS : Boolean = TRUE; {tells sort whether to use EMS if } + {available and needed} + MaxHeapToUse : LongInt = 655210; + STemp : String[5] = 'STEMP'; + +TYPE + + {these are the possible return values of the sort routines} + MSortStatus = (MSortSuccess, {Successful sort} + MSortOutOfMemory, {insufficient memory} + MSortDiskError, {disk I/O error} + MSortOutOfDisk, {insufficient disk space for merge} + MSortEMSError, {EMM error} + MSortUserAbort); {User abort} {!!.05} + + PathName = String[79]; {string type for pathnames} + +var + UsingEMS : Boolean; + GRunLength : Word; {To store the run length} + MSortIOResult : Integer; {Stores last IOResult value} + LastFileName : PathName; {The name of the last file written to} + +function DoSort(RunLength : Word; + RecLength : Word; + InFileBufMax : Word; + OutFileBufMax : Word; + TempPath : PathName; + GetElements : Pointer; + LessFunc : Pointer; + PutElements : Pointer + ) : MSortStatus; +{-low level sorting routine} + + +function AutoSort(FSizeInRecs : LongInt; + RecLength : Word; + TempPath : PathName; + GetElements : Pointer; + LessFunc : Pointer; + PutElements : Pointer + ) : MSortStatus; +{-high level sorting routine} + +function AutoSortInfo(FSizeInRecs : LongInt; + RecLength : Word; + var HeapSpace : LongInt; + var DiskSpace : LongInt; + var FileHandles : Word; + var EMSPages : Word; + var RunLen : Word; + var FileBufs : Word; + var OutFileBufs : Word; + var AllInMem : Boolean) : MSortStatus; + + +function PutElement(var X) : Boolean; +{-Submits a record to the sort system. Returns TRUE is record successfully} +{submitted.} + +function GetElement(var X) : Boolean; +{-Returns a record from the sort system. Returns TRUE while there are more} +{ records to return. When FALSE is returned, the value of the VAR X is } +{ undefined.} + +procedure AbortSort; +{-Prematurely halt the sort from the user defined routines} + +implementation + +const + MAXRUNLENGTH = $FFFF; {maximum number of elements per Run} + UserFree = 128; +{$IFDEF Ver55} {!!.06} + UserFreeMin = 16; +{$ENDIF} {!!.06} + AllInMem : Boolean = FALSE; {to indicate whether the entire file} + {to be sorted is in memory} + GFSizeInRecs : LongInt = MaxLongInt; + +type + FileName = String[13]; + BufferType = Array[1..$FFFF] of Char; {a buffer of Characters} + HugeArray = Pointer; {for data structures larger than 64k} + FDBuffer = Array[1..MERGEORDER] of File; {the input file list} + FDBuf = ^FDBuffer; + MarkRec = record + Marker : Pointer; + FreeBuf : Pointer; + OldFreePtr : Pointer; + BufSize : Word; + end; {used by fast heap routines MarkFL and ReleaseFL} + +var + BufferPos, {to hold the current position within each of the I/O buffers} + BufferSize {to hold the size of each of the buffers} + : Array[0..MERGEORDER] of Word; + + {The following var holds pointers to the I/O buffers. Position 0 } + {is the output buffer, and positions 1..MERGEORDER are for each of} + {the input files.} + Buffer : Array[0..MERGEORDER] of ^BufferType; + + RecBufSeg : Word; {The segment of the address of RecBuf} + RecBuf : HugeArray; {This huge array holds pointers to the data.} + {It may exceed 64K in size if necessary.} + RecBufSave : Pointer; {to save the original value of RecBuf} {!!.04} + HeapMark : MarkRec; + UserLess : Pointer; {points to the user's Less procedure} + UserGet : Pointer; {points to the user's GetElements procedure} + UserPut : Pointer; {points to the user's PutElements procedure} + GTempPath : PathName; {Pathname to store temporary files} + NumElements, + ElementCount : LongInt; {Used by sort routines to count elements} + FileBufferMax : Word; {The maximum size of an input file buffer} + InFilePtr : FDBuf; {a record to hold all the input files for merge} + OutFile : File; {The output file} + Pivot : Pointer; {pointer to pivot element for QuickSort} + TempRec : Pointer; {pointer to temporary record} + OutBufSize : Word; {size of the output buffer} + HighF : Word; + NumElemInRun : Word; {element number within this run} + PtrBufLength : LongInt; {The length of the pointer buffer for data} + GRecLength : Word; {To store the record length of the data items} + + Pl : Word; {Left edge within partition} + Pr : Word; {Right edge within partition} + + GBasePtr : Pointer; + GBytes : LongInt; + MSortResult : MSortStatus; {global sort status} + +function GetDiskInfo(Drive : Byte; var ClustersAvailable, TotalClusters, + BytesPerSector, SectorsPerCluster: Word) : Boolean; +begin +Inline( + $8A/$96/>DRIVE/ { mov dl,>Drive[BP]} + $B4/$36/ { mov ah,$36} + $CD/$21/ { int $21} + $3D/$FF/$FF/ { cmp ax,$FFFF} + $74/$20/ { je GDIError} + $1E/ { push ds} + $C5/$BE/>SECTORSPERCLUSTER/ { lds di,>SectorsPerCluster[BP]} + $89/$05/ { mov [di],ax} + $C5/$BE/>BYTESPERSECTOR/ { lds di,>BytesPerSector[BP]} + $89/$0D/ { mov [di],cx} + $C5/$BE/>TOTALCLUSTERS/ { lds di,>TotalClusters[BP]} + $89/$15/ { mov [di],dx} + $C5/$BE/>CLUSTERSAVAILABLE/ { lds di,>ClustersAvailable[BP]} + $89/$1D/ { mov [di],bx} + $1F/ { pop ds} + $C6/$46/ Dest} + $07/ {pop es} + $FC/ {cld ;go forward} + $F2/$AB); {rep stosw ;fill memory} + + function EmsInstalled : Boolean; + {-Returns true if the Expanded Memory Manager is installed.} + var + F : file; + begin + Assign(F, 'EMMXXXX0'); + Reset(F); + if IoResult = 0 then begin + EmsInstalled := True; + Close(F); + end + else + EmsInstalled := False; + end; + +{$I msortems.inc} + +{$IFNDEF BigHeap} + procedure MarkFL(var HeapMark : MarkRec); + {-Mark the current top of heap and buffer the free list} + begin + with HeapMark do begin + {$IFDEF Ver55} + if Ofs(FreePtr^) = 0 then + {Free list is empty} + FreeBuf := nil + else begin + {Buffer the free list} + BufSize := LongInt(65536)-Ofs(FreePtr^); + {Allow for possibility of free list growth} + if BufSize < $FFF8 then + inc(BufSize, 8); + GetMem(FreeBuf, BufSize); + if FreeBuf <> nil then begin + OldFreePtr := FreePtr; + Move(FreePtr^, FreeBuf^, LongInt(65536)-Ofs(FreePtr^)); + end; + end; + {$ENDIF} + {Mark the top of the heap} + Mark(Marker); + end; + end; + + procedure ReleaseFL(HeapMark : MarkRec); + {-Release the heap at heap mark and restore the free list} + begin + with HeapMark do begin + {Release from the marker} + Release(Marker); + {$IFDEF Ver55} + if FreeBuf <> nil then begin + {Reset FreePtr} + FreePtr := OldFreePtr; {!!.10} + {Restore free list} + Move(FreeBuf^, FreePtr^, LongInt(65536)-Ofs(FreePtr^));{!!.10} + {Dispose of the free list buffer} + FreeMem(FreeBuf, BufSize); + end; + {$ENDIF} + end; + end; +{$ENDIF} + +procedure GetRecBuffer(Size : LongInt); +{-Get the record buffer, and ensure it starts on a 0 offset} + +var + Off : Word; + +begin + HugeGetMem(RecBuf,Size+15); + if (RecBuf = NIL) then begin + MSortResult := MSortOutOfMemory; + Exit; + end; + RecBufSave := RecBuf; {!!.04} + Off := SegOfs(RecBuf).Ofst; + if (Off <> 0) then begin {if offset not zero, then make it zero} + SegOfs(RecBuf).Ofst := 16; + Pointer(RecBuf) := Normalized(RecBuf); + end; + RecBufSeg := SegOfs(RecBuf).Segm; +end; + +procedure FreeRecBuffer(Size : LongInt); +{-Free the Record buffer} +begin + HugeFreeMem(RecBufSave,Size+15); {!!.04} +end; + +function GetPointerPr : Pointer; +{-this macro returns a pointer to the element at index Pr within RecBuf} +Inline( + $8B/$16/>RECBUFSEG/ { mov DX,[>RecBufSeg]} + $31/$DB/ { xor BX,BX} + $A1/>PR/ { mov AX,[>Pr]} + $48/ { dec AX} + $D1/$E0/ { shl AX,1} + $D1/$D3/ { rcl BX,1} + $D1/$E0/ { shl AX,1} + $D1/$D3/ { rcl BX,1} + $B1/$04/ { mov CL,4} + $D2/$E3/ { shl BL,CL} + $00/$DE); { add DH,BL} + +function GetPointerPl : Pointer; +{-this macro returns a pointer to the element at index Pl within RecBuf} +Inline( + $8B/$16/>RECBUFSEG/ { mov DX,[>RecBufSeg]} + $31/$DB/ { xor BX,BX} + $A1/>PL/ { mov AX,[>Pl]} + $48/ { dec AX} + $D1/$E0/ { shl AX,1} + $D1/$D3/ { rcl BX,1} + $D1/$E0/ { shl AX,1} + $D1/$D3/ { rcl BX,1} + $B1/$04/ { mov CL,4} + $D2/$E3/ { shl BL,CL} + $00/$DE); { add DH,BL} + +procedure IncPtr(var P : Pointer; Increment : Word); +{-increments a pointer by Increment and normalizes it} +begin + Inc(SegOfs(P).Ofst,Increment); + P := Normalized(P); +end; + +procedure AllocRunBuffers; +{-allocate space for an entire run's worth of data} +var + I : Word; + P : Pointer; + +begin +{$IFNDEF BigHeap} + MarkFL(HeapMark); +{$ENDIF} + + GetRecBuffer(PtrBufLength); + if MSortResult <> MSortSuccess then Exit; +{$IFDEF BigHeap} + GBytes := LongInt(GRecLength) * GRunLength; {!!.02} + HugeGetMem(GBasePtr,GBytes); + if GBasePtr = NIL then begin {!!.02} + MSortResult := MSortOutOfMemory; {!!.02} + Exit; {!!.02} + end; + P := GBasePtr; + for I := 1 to GRunLength do begin + Pr := I; + Pointer(GetPointerPr^) := P; + IncPtr(P,GRecLength); + end; +{$ELSE} + for I := 1 to GRunLength do begin + Pr := I; + GetMem(Pointer(GetPointerPr^),GRecLength); + end; +{$ENDIF} +end; + +procedure DeallocRunBuffers; +{-deallocate the space used by the run data} + +{$IFNDEF BigHeap} +var + I : Word; + P : Pointer; +{$ENDIF} + +begin +{$IFDEF BigHeap} + HugeFreeMem(GBasePtr,GBytes); + FreeRecBuffer(PtrBufLength); +{$ELSE} + ReleaseFL(HeapMark); +{$ENDIF} +end; + +procedure AllocIOBuffers; +{-allocate the input file data buffers} + +var + I : Word; + +begin + {$IFNDEF BigHeap} + MarkFL(HeapMark); + {$ENDIF} + for I := 1 to MERGEORDER do begin + if FileBufferMax > 0 then begin + GetMem(Buffer[I],FileBufferMax); + if Buffer[I] = NIL then begin + MSortResult := MSortOutOfMemory; + Exit; + end; + end; + BufferPos[I] := FileBufferMax + 1; + BufferSize[I] := FileBufferMax; + end; +end; + +procedure DeallocIOBuffers; +{-deallocate the input file data buffers} + +var + I : Word; + +begin + {$IFDEF BigHeap} + for I := 1 to MERGEORDER do + FreeMem(Buffer[I],FileBufferMax); + {$ELSE} + ReleaseFL(HeapMark); + {$ENDIF} +end; + +function MakePathName(N : FileName) : PathName; +{-appends a filename to the path for temporary files} +begin + MakePathName := GTempPath + N; +end; + +function Min(A, B : Word) : Word; + {-Returns the smaller of A and B} + inline( + $58/ {pop ax} + $5B/ {pop bx} + $39/$C3/ {cmp bx,ax} + $73/$02/ {jae done} + $89/$D8); {mov ax,bx} + {done:} + +procedure ExchangeWords(var I, J : Word); + {-Exchange words I and J. Useful in sorts} + inline( + $8C/$DB/ {mov bx,ds ;save DS} + $5E/ {pop si} + $1F/ {pop ds ;DS:SI => J} + $5F/ {pop di} + $07/ {pop es ;ES:DI => I} + $8B/$04/ {mov ax,[si] ;AX = J} + $26/$87/$05/ {xchg ax,es:[di] ;I = J, AX = I} + $89/$04/ {mov [si],ax ;J = I} + $8E/$DB); {mov ds,bx ;restore DS} + +procedure ExchangePtr(var A,B); +{-Exchange pointers A and B. Useful in sorts} +Inline( + $8C/$DA/ { mov DX,DS} + $5E/ { pop SI} + $1F/ { pop DS} + $5F/ { pop DI} + $07/ { pop ES} + $8B/$04/ { mov AX,[SI]} + $26/ { ES:} + $87/$05/ { xchg AX,[DI]} + $89/$04/ { mov [SI],AX} + $46/ { inc SI} + $46/ { inc SI} + $47/ { inc DI} + $47/ { inc DI} + $8B/$04/ { mov AX,[SI]} + $26/ { ES:} + $87/$05/ { xchg AX,[DI]} + $89/$04/ { mov [SI],AX} + $8E/$DA); { mov DS,DX} + + +function ULess(var X, Y) : Boolean; + {-Call the user routine to perform element comparison} + inline($FF/$1E/>UserLess); {CALL DWORD PTR [>UserLess]} + +procedure CallGetElements; + {-Call the user GetEl routine} + inline($FF/$1E/>UserGet); {CALL DWORD PTR [>UserGet]} + +procedure CallPutElements; + {-Call the user PutEl routine} + inline($FF/$1E/>UserPut); {CALL DWORD PTR [>UserPut]} + +procedure GetPivot(L, R : Word); +{-Load the pivot element} +var + Sav : Word; + +begin + {Use a random pivot index to help with pre-sorted arrays} + Sav := Pr; + Pr := L+Random(R-L); + Move(Pointer(GetPointerPr^)^,Pivot^,GRecLength); + Pr := Sav; +end; + + procedure QuickSort(L, R : Word); + {-Non-recursive QuickSort per N. Wirth's "Algorithms and Data Structures"} + const + StackSize = 20; + type + Stack = array[1..StackSize] of Word; + var + Lstack : Stack; {Pending partitions, left edge} + Rstack : Stack; {Pending partitions, right edge} + StackP : Integer; {Stack pointer} + begin + {Initialize the stack} + StackP := 1; + Lstack[1] := L; + Rstack[1] := R; + + {Repeatedly take top partition from stack} + repeat + {Pop the stack} + L := Lstack[StackP]; + R := Rstack[StackP]; + Dec(StackP); + + {Sort current partition} + repeat + {Load the pivot element} + GetPivot(L,R); + Pl := L; + Pr := R; + {Swap items in sort order around the pivot index} + repeat + while ULess(Pointer(GetPointerPl^)^,Pivot^) do + Inc(Pl); + while ULess(Pivot^, Pointer(GetPointerPr^)^) do + Dec(Pr); + if Pl <= Pr then begin + if Pl <> Pr then + {Swap the two elements} + ExchangePtr(Pointer(GetPointerPl^),Pointer(GetPointerPr^)); + + if Pl < 65535 then + Inc(Pl); + if Pr > 0 then + Dec(Pr); + end; + until Pl > Pr; + {Decide which partition to sort next} + if (Pr-L) < (R-Pl) then begin + {Left partition is bigger} + if Pl < R then begin + {Stack the request for sorting right partition} + Inc(StackP); + Lstack[StackP] := Pl; + Rstack[StackP] := R; + end; + {Continue sorting left partition} + R := Pr; + end else begin + {Right partition is bigger} + if L < Pr then begin + {Stack the request for sorting left partition} + Inc(StackP); + Lstack[StackP] := L; + Rstack[StackP] := Pr; + end; + {Continue sorting right partition} + L := Pl; + end; + + until L >= R; + + until StackP <= 0; + end; + +procedure QuickSortIt(NLines : Word); +{-calls the non-recursive quicksort} +begin + QuickSort(1,NLines); +end; + +procedure GName(N : Word; var Name : FileName); +{-create a file name in format STEMPxx where xx is a number} +VAR + Scratch : String[8]; + +begin + Str(N,Scratch); + Name := STemp + Scratch; +end; + +procedure MakeFile(var F : File; N : Word; Size : LongInt); +{-create a new file} + +var + Name : PathName; + +begin + GName(N,Name); + LastFileName := MakePathName(Name); + + Open_OutFile(F,LastFileName,Size); + BufferPos[0] := 1; +end; + +function GOpen(var InFilePtr : FDBuf; F1,F2 : Word) : LongInt; +{-open files F1 through F2} + +var + Name : PathName; + I : 1..MERGEORDER; + Size : LongInt; + +begin + Size := 0; + + for I := 1 to F2-F1+1 do begin + GName(F1+I-1,Name); + Name := MakePathName(Name); + Open_InFile(InFilePtr^[I],Name,I); + if FileRec(InFilePtr^[I]).Mode = fmEMS then + Size := Size + FileRec(InFilePtr^[I]).ActualSize + + else begin + Size := Size + FileSize(InFilePtr^[I]); +(*code commented out as of 5.22 !!.22 + MSortIOResult := IOResult; + if MSortIOResult <> 0 then + MSortResult := MSortDiskError; +*) + end; + end; + BufferPos[I] := FileBufferMax + 1; + BufferSize[I] := FileBufferMax; + GOpen := Size; +end; + +procedure CloseOutFile(var F : File); +{-close an output file (flushing buffers if necessary)} + +var + Size,Num : Word; + +begin + Size := BufferPos[0] - 1; + if UsingEMS and (FileRec(F).Mode = fmEMS) then begin + if Size > 0 then + EMSBlockWrite(F,Buffer[0]^,Size,Num); + CloseEMSFile(F) + end + else begin + if Size > 0 then begin + BlockWrite(F,Buffer[0]^,Size,Num); + MSortIOResult := IOResult; + if (MSortIOResult <> 0) or (Num <> Size) then begin + MSortResult := MSortDiskError; + if (MSortIOResult = 0) then + MSortIOResult := -1; + end; + end; + Close(F); + if MSortIOResult = 0 then begin + MSortIOResult := IOResult; + if MSortIOResult <> 0 then + MSortResult := MSortDiskError; + end + else + if IOResult = 0 then ; + end; +end; + +procedure PutARec(var F : File; var S); +{-put a record to the output File specified as F} + +var + Size,Num : Word; + +begin + if BufferSize[0] = 0 then begin + {if we're not buffering the output...} + + if UsingEMS and (FileRec(F).Mode = fmEMS) then begin + EMSBlockWrite(F,S,GRecLength,Num) + + end + else begin + BlockWrite(F,S,GRecLength,Num); + MSortIOResult := IOResult; + if (MSortIOResult <> 0) or (Num <> GRecLength) then begin + MSortResult := MSortDiskError; + if (MSortIOResult = 0) then + MSortIOResult := -1; + end; + end; + end + else begin + {we are buffering the output} + Size := BufferPos[0] - 1; + {see if we need to write out the buffer because its full} + if LongInt(Size) + GRecLength > BufferSize[0] then begin {!!.40} + if UsingEMS and (FileRec(F).Mode = fmEMS) then begin + EMSBlockWrite(F,Buffer[0]^,Size,Num); + {******} + end + else begin + BlockWrite(F,Buffer[0]^,Size,Num); + MSortIOResult := IOResult; + if (MSortIOResult <> 0) or (Num <> Size) then begin + MSortResult := MSortDiskError; + if (MSortIOResult = 0) then + MSortIOResult := -1; + Exit; + end; + end; + BufferPos[0] := 1; + end; + {move the record S into the output buffer} + Size := BufferPos[0]; + Move(S,Buffer[0]^[Size],GRecLength); + BufferPos[0] := Size + GRecLength; + end; +end; + +function GetARec(var Line; var F : File; Index : Integer) : Boolean; +{-get a record from the input file F (which is InFilePtr^[Index]) } + +var + Reread,Buffered,EMS + : Boolean; + NumRead : Word; + +begin + GetARec := TRUE; + EMS := UsingEMS and (FileRec(F).Mode = fmEMS); {this file in EMS?} + + {Is the Input buffer exhausted, do we need another buffer full?} + Reread := BufferPos[Index] + GRecLength - 1 > BufferSize[Index]; + + {Are we utilizing an input buffer?} + Buffered := BufferSize[Index] > 0; + if Buffered then begin + + if Reread then begin + {we need a new buffer full, so check to see if in EMS or on disk} + if EMS then begin + if EMS_EOF(F) then begin + GetARec := FALSE; + Exit; + end; + EMSBlockRead(F,Buffer[Index]^,FileBufferMax,BufferSize[Index]); + MSortIOResult := IOResult; + BufferPos[Index] := 1; + end + else begin + if EOF(F) then begin + GetARec := FALSE; + Exit; + end; + BlockRead(F,Buffer[Index]^,FileBufferMax,BufferSize[Index]); + MSortIOResult := IOResult; + BufferPos[Index] := 1; + end; + end; + + {get the record from the input buffers} + Move(Buffer[Index]^[BufferPos[Index]],Line,GRecLength); + BufferPos[Index] := BufferPos[Index] + GRecLength; + end + else + begin {!!.42} + {no buffering, so read directly} + if EMS then {!!.42} + begin {!!.42} + if EMS_EOF(F) then {!!.42} + begin {!!.42} + GetARec := FALSE; {!!.42} + Exit; {!!.42} + end; {!!.42} + EMSBlockRead(F,Line,GRecLength, NumRead); {!!.42} + MSortIOResult := IOResult; {!!.42} + if (MSortIOResult <> 0) then {!!.42} + begin {!!.42} + MSortResult := MSortEMSError; {!!.42} + GetARec := FALSE; {!!.42} + end; {!!.42} + end {!!.42} + else {!!.42} + begin {!!.42} + if EOF(F) then + GetARec := FALSE + else begin + BlockRead(F,Line,GRecLength); + MSortIOResult := IOResult; + if MSortIOResult <> 0 then begin + MSortResult := MSortDiskError; + GetARec := FALSE; + end; + end; + end; {!!.42} + end; +end; + +procedure GRemove(var InFilePtr : FDBuf; F1,F2 : Word); +{-close the InFiles specified in InFilePtr from F1, F2, and delete them} + +var + Name : String; + I : 1..MERGEORDER; + +begin + for I := 1 to F2-F1+1 do + if (not UsingEMS) or (FileRec(InFilePtr^[I]).Mode <> fmEMS) then begin + Close(InFilePtr^[I]); + if IOResult <> 0 then ; {just clear IOResult} + Erase(InFilePtr^[I]); + if IOResult <> 0 then ; {just clear IOResult} + end; +end; + +function GetARun(var Nlines : Word; var InF : File; + II : Word) : Boolean; +{- load an entire run into the Run Buffers, return TRUE if entire Run } +{returned, and FALSE if end of input encountered} + +var + NextPos : Word; + Done : Boolean; + +begin + Nlines := 0; + repeat + Done := (GetARec(TempRec^,InF,II) = FALSE); + if Not Done then begin + Inc(NLines); + NextPos := NLines + 1; + Pr := NLines; + Move(TempRec^,Pointer(GetPointerPr^)^,GRecLength); + end; + until (Done) or (NLines >= GRunLength); + GetARun := Done; +end; + +procedure PutARun(NLines : Word; var OutFile : File); +{-writes a Run to disk (or EMS)} + +var + I : Word; + +begin + for I := 1 to NLines do begin + Pr := I; + PutARec(OutFile,Pointer(GetPointerPr^)^); + end; +end; + + +function PutElement(var X) : Boolean; +{-Submits a record to the sort system. Returns TRUE is record successfully} +{submitted.} + + +begin + if (MSortResult = MSortSuccess) and (NumElements < GFSizeInRecs) then + PutElement := TRUE + else begin + PutElement := FALSE; + Exit; + end; + + {if there is still room in RAM, add record to the run buffer, otherwise} + {sort what's in the run buffer and write out the Run first (flush the } + {run), and add the record to the run buffer} + if (NumElemInRun < GRunLength) then begin + Inc(NumElemInRun); + Pr := NumElemInRun; + + Move(X,Pointer(GetPointerPr^)^,GRecLength); + end + else begin + QuickSortIt(NumElemInRun); {non recursive QS} + + Inc(HighF); + MakeFile(OutFile,HighF,LongInt(GRunLength)*GRecLength); + PutARun(NumElemInRun,OutFile); + CloseOutFile(OutFile); + NumElemInRun := 1; + Pr := 1; + Move(X,Pointer(GetPointerPr^)^,GRecLength); + end; + Inc(NumElements); +end; + +{this type is used by the Merge System} +type + MergeItem = record + F : Word; + P : Pointer; + HP : Pointer; + end; + +{used by Merge System} +var + MergeList : Array[1..MERGEORDER] of MergeItem; + +procedure Exchange(var Item1,Item2 : MergeItem); +{-exchanges two MergeItems in the MergeList. Note: The field HP is not} +{exchanged!!} + +begin + with Item1 do begin + ExchangePtr(P,Item2.P); + ExchangeWords(F,Item2.F); + end; +end; + +procedure SortMergeList(NF : Word); +{-simple bubblesort on MergeList. The MergeList always contains only } +{MERGEORDER elements, so a bubblesort is adequate.} +var + I,J : Word; + +begin + for I := NF Downto 2 do + for J := 1 to I-1 do + if ULess(MergeList[J+1].P^,MergeList[J].P^) then + Exchange(MergeList[J+1],MergeList[J]); +end; + +procedure ReHeap(NF : Word); +{-make sure first element in MergeList is the smallest} + +var + I,J : Word; + +begin + i := 1; + J := 2 * i; + while (J <= NF) do begin + if (J < NF) then + if not ULess(MergeList[J].P^,MergeList[J+1].P^) then + Inc(J); + + if ULess(MergeList[I].P^,MergeList[J].P^) then + I := NF + else + Exchange(MergeList[I],MergeList[J]); + + I := J; + J := 2 * I; + end; +end; + +{variables used by the Merge System} +var + LowF,Lim : Word; + NumFiles : Word; + LastMerge : Boolean; + BottomLoop : Boolean; + MergeDone : Boolean; + +function MoreToMerge : Boolean; +{-this routine returns TRUE while there is more data to be merged. Sets } +{some important merge System variables} +var + I : Word; + MergeSize : LongInt; + +begin + MoreToMerge := TRUE; + if BottomLoop and (MSortResult = MSortSuccess) then + Exit; + if LowF < HighF then begin + + Lim := Min(LowF+MergeOrder-1,HighF); + NumFiles := Lim-LowF+1; + MergeSize := GOpen(InFilePtr,LowF,Lim); + if MSortResult <> MSortSuccess then begin {!!.22} + MoreToMerge := False; {!!.22} + Exit; {!!.22} + end; {!!.22} + Inc(HighF); + LastMerge := (LowF + MERGEORDER >= HighF); + if not LastMerge then + MakeFile(OutFile,HighF,MergeSize); + + for I := 1 to NumFiles do + with MergeList[I] do begin + P := HP; + if GetARec(P^,InFilePtr^[I],I) then + F := I; + end; + SortMergeList(NumFiles); + BottomLoop := TRUE; + end + else + MoreToMerge := FALSE; +end; + +function GetElement(var X) : Boolean; +{-Returns a record from the sort system. Returns TRUE while there are more} +{ records to return. When FALSE is returned, the value of the VAR X is } +{ undefined.} + +{This is a complex routine. The Merge Sort Phase, if it is needed, is } +{actually performed here. The merging technology used by this program is } +{somewhat complicated, due to two factors: The fact that the source of the } +{input and destination of the output is unknown to the Sort routines. } +{The final merge of the data is not performed to disk, but is actually } +{performed to the output stream (this limits the amount of disk space and } +{time needed by the merge sort).} + + +const + LBP = 1; + +var + FIndex : Word; + Error : Boolean; + +begin + Error := FALSE; + if (not MergeDone) and (MSortResult = MSortSuccess) then + GetElement := TRUE + else begin + GetElement := FALSE; + Exit; + end; + if AllInMem then begin + {if the sort is being performed entirely in memory, then just return the} + {next element in the run buffer.} + if ElementCount > 0 then begin + Pr := NumElements - (ElementCount-1); + Move(Pointer(GetPointerPr^)^,X,GRecLength); + Dec(ElementCount); + end + else + GetElement := FALSE; + end + else + {not all in memory, so perform the special merge sort technique} + repeat + if MoreToMerge and (MSortResult = MSortSuccess) then begin + if LastMerge then + Move(MergeList[LBp].P^,X,GRecLength) + else + PutARec(OutFile,MergeList[LBp].P^); + FIndex := MergeList[LBp].F; + if not GetARec(TempRec^,InFilePtr^[FIndex],FIndex) then begin + {InFilePtr^[FIndex] is exhausted, so decrement num files} + Exchange(MergeList[LBp],MergeList[NumFiles]); + Dec(NumFiles); + if NumFiles = 0 then begin + if LastMerge then + MergeDone := TRUE + else begin + BottomLoop := FALSE; + CloseOutFile(OutFile); + end; + GRemove(InFilePtr,LowF,Lim); + LowF := LowF + MergeOrder; + end; + end + else + with MergeList[1] do begin + Move(TempRec^,P^,GRecLength); + F := FIndex; + end; + ReHeap(NumFiles); + end + else + GRemove(InFilePtr,LowF,Lim); + Error := (MSortResult <> MSortSuccess); + until LastMerge or Error; + if Error then begin + GetElement := FALSE; + end; +end; + +procedure MergeSort; +{-this procedure calls the user routine to retrieve the sorted elements. If } +{a merge phase is required, it is performed during the calls to GetElement } +{(see the comments in GetElement above). } +var + I : Word; + +begin + {If not all in memory, then allocate the I/O buffers} + if not AllinMem then begin + AllocIOBuffers; + + {allocate the memory for the MergeList data} + for I := 1 to MERGEORDER do + with MergeList[I] do + GetMem(HP,GRecLength); + end; + + {initialize some important sort system variables} + LowF := 1; + LastMerge := FALSE; + BottomLoop := FALSE; + MergeDone := FALSE; + + {call the user routine if everything is kosher} + if MSortResult = MSortSuccess then + CallPutElements; + + if not AllInMem then begin + {free the memory used by the MergeList data} + for I := 1 to MERGEORDER do + FreeMem(MergeList[I].HP,GRecLength); + + {if I/O buffers were allocated, then free them} + DeallocIOBuffers; + + if MSortResult <> MSortSuccess then {!!.52} + {close and delete any open merge files} {!!.52} + GRemove(InFilePtr,LowF,Lim); {!!.52} + end; +end; + + +function DoSort(RunLength : Word; + RecLength : Word; + InFileBufMax : Word; + OutFileBufMax : Word; + TempPath : PathName; + GetElements : Pointer; + LessFunc : Pointer; + PutElements : Pointer + ) : MSortStatus; + +{-the lowest level sorting routine. This function sorts the elements. It } +{calls the user GetElements routine to get the elements to be sorted, calls} +{the LessFunc to compare the items, and calls the user PutElements } +{procedure upon completion.} + + +Label ExitPoint,FinalExitPoint; + +{$IFDEF Ver55} {!!.06} +var + FreeMinSave : Word; +{$ENDIF} {!!.06} +var {!!.53} + RunBuffAllocated : Boolean; {!!.53} + +begin + UsingEMS := False; {!!.40} + + {$IFDEF Ver55} {!!.06} + {Set FreeMin to some reasonable value (preserving its original contents)} + FreeMinSave := FreeMin; + if FreeMin < UserFreeMin then + FreeMin := UserFreeMin; + {$ENDIF} {!!.06} + + {initialize EMS related globals} + UsingEMS := EMS_Init; + if UsingEMS then + GetMem(EMSFat,SizeOf(EMSFat^)); {!!.03} + + {Allocate the InFilePtr data structure} + + GetMem(InFilePtr,SizeOf(InFilePtr^)); {!!.03} + + {assume success} + MSortResult := MSortSuccess; + + {set some global variables needed by the sort system} + GRecLength := RecLength; + GRunLength := RunLength; + if (TempPath <> '') and + (TempPath[Length(TempPath)] <> '\') then + GTempPath := TempPath + '\' + else + GTempPath := TempPath; + + UserLess := LessFunc; + UserGet := GetElements; + UserPut := PutElements; + + {calculate the Run Pointer Buffer size} + PtrBufLength := LongInt(RunLength) * SizeOf(Pointer); + + {ensure that buffer is an appropriate size} + OutBufSize := (OutFileBufMax DIV RecLength) * RecLength; + + {Allocate space for two elements on heap} + GetMem(Pivot,GRecLength); + GetMem(TempRec,GRecLength); + + {get memory for output buffer and set buffer variables} + if OutBufSize > 0 then begin + GetMem(Buffer[0],OutBufSize); + if Buffer[0] = NIL then begin + MSortResult := MSortOutOfMemory; + Goto FinalExitPoint; + end; + end; + BufferPos[0] := OutBufSize + 1; + BufferSize[0] := OutBufSize; + + {figure out InFilePtr buffer size} + FileBufferMax := ((InFileBufMax DIV MERGEORDER) DIV RecLength) + * RecLength; + + NumElements := 0; + NumElemInRun := 0; + HighF := 0; + + {allocate the memory needed to store a Run in RAM} + AllocRunBuffers; + RunBuffAllocated := True; {!!.53} + + {if error then exit} + if MSortResult <> MSortSuccess then + Goto FinalExitPoint; + + {call the user routine to get the elements into the sort system} + CallGetElements; + + {check to see if all the records fit in RAM} + if (NumElements <= GRunLength) then {!!.05} + AllInMem := TRUE; {!!.05} + + if (MSortResult <> MSortSuccess) or (NumElements = 0) then {!!.04} + Goto ExitPoint; {if error then exit} + + {Sort the run currently in RAM} + QuickSortIt(NumElemInRun); + {If there's more than just that run, then output it in preparation for} + {merge phase} + if (not AllInMem) and (MSortResult = MSortSuccess) then begin + Inc(HighF); + MakeFile(OutFile,HighF,LongInt(GRunLength)*GRecLength); + PutARun(NumElemInRun,OutFile); + CloseOutFile(OutFile); + DeallocRunBuffers; + RunBuffAllocated := False; {!!.53} + end; + + if MSortResult <> MSortSuccess then + Goto ExitPoint; + + ElementCount := NumElements; + + {Do the merge sort logic} + MergeSort; + +ExitPoint: + if RunBuffAllocated then {!!.53} + DeallocRunBuffers; + + AllInMem := FALSE; + + + FreeMem(Buffer[0],OutBufSize); + + FreeMem(TempRec,GRecLength); + FreeMem(Pivot,GRecLength); + FreeMem(InFilePtr,SizeOf(InFilePtr^)); {!!.03} + + {if we used EMS, then free all pages} + if UsingEMS then begin + EMS_Close_All; + FreeMem(EMSFat,SizeOf(EMSFat^)); {!!.03} + end; +FinalExitPoint: + DoSort := MSortResult; +{$IFDEF Ver55} {!!.06} + FreeMin := FreeMinSave; {!!.04} +{$ENDIF} {!!.06} +end; + +function FreeDiskSpace(DriveNo : Byte) : LongInt; +{-returns number of bytes free on specified disk (0=default, 1=A:, 2=B:...)} + +var + ClusAvail,TotalClus,BytesPerSect,SectsPerClus + : Word; + BytesPerClus : LongInt; + +begin + if GetDiskInfo(DriveNo,ClusAvail,TotalClus, + BytesPerSect,SectsPerClus) then begin + BytesPerClus := LongInt(SectsPerClus) * LongInt(BytesPerSect); + FreeDiskSpace := LongInt(ClusAvail) * BytesPerClus; + end + else begin + FreeDiskSpace := -1; + end; +end; + +const + BUFSLICE = 14; + + +{$I msortinf.inc} {The AutoSortInfo routine} + + +function AutoSort(FSizeInRecs : LongInt; + RecLength : Word; + TempPath : PathName; + GetElements : Pointer; + LessFunc : Pointer; + PutElements : Pointer + ) : MSortStatus; + +{-this is the high level sort routine. Similar to DoSort, except it} +{calculates optimum sizes for the sort parameters and checks for } +{sufficient resources before attempting sort. Calls AutoSortInfo } +{to calculate sort parameters.} + +var + RunLen,FileBufs,OutFileBufs + : Word; + FileHands,EMSPgs : Word; + HeapSp,DiskSp : LongInt; + +function ResourcesAvailable : Boolean; + +var + DiskSpaceFree : LongInt; + DriveNo : Byte; + +begin + ResourcesAvailable := FALSE; + if Pos(':',TempPath) = 2 then + DriveNo := Ord(UpCase(TempPath[1])) - (Ord('A') - 1) + else + DriveNo := 0; + DiskSpaceFree := FreeDiskSpace(DriveNo); + if AllInMem or (DiskSpaceFree >= DiskSp) then + ResourcesAvailable := TRUE + +end; + +var + Res : MSortStatus; +begin + + Res := AutoSortInfo(FSizeInRecs,RecLength,HeapSp,DiskSp,FileHands, + EMSPgs,RunLen,FileBufs,OutFileBufs,AllInMem); + + if Res = MSortSuccess then begin + if ResourcesAvailable then begin + GFSizeInRecs := FSizeInRecs; + AutoSort := DoSort(RunLen,RecLength,FileBufs,OutFileBufs,TempPath, + GetElements,LessFunc,PutElements); + GFSizeInRecs := MaxLongInt; + end + else + AutoSort := MSortOutOfDisk; + end + else + AutoSort := Res; + +end; + +procedure AbortSort; +{-Prematurely halt the sort from the user defined routines} +begin + MSortResult := MSortUserAbort; +end; + +begin + {set up an exit procedure to automatically free any EMS pages used by } + {MSort in the case of a fatal runtime error.} + + EMSSaveExitProc := ExitProc; + NumInEMSFat := 0; + ExitProc := @EMS_ExitProc; +end. diff --git a/src/wc_sdk/msortems.inc b/src/wc_sdk/msortems.inc new file mode 100644 index 0000000..642c421 --- /dev/null +++ b/src/wc_sdk/msortems.inc @@ -0,0 +1,384 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +const + PageSize = 16384; + fmEMS = $D7BF; + EMSFILEMAX = 128; + EmsErrorCode = $0FFFF; {Used by several functions to signal an error} + +type + FileRec = record + Handle: Word; + Mode: Word; + RecSize: Word; + Private: array[1..26] of Byte; + CurrentPage : Byte; + NumPages : Byte; + Index : LongInt; + ActualSize : LongInt; + EMSHandle : Word; + UserData: array[13..16] of Byte; + Name : String[79]; + end; + + EMSFatRec = record + ID : Word; + Handle : Word; + Size : LongInt; + end; + EMSFatType = Array[1..EMSFILEMAX] of EMSFatRec; + EMSFatTypePtr = ^EMSFatType; + EMSPage = Array[1..PAGESIZE] of Byte; + ShortEMSPage = Array[1..16000] of Byte; + EMSPageFrameType = record + Page0,Page1,Page2 : EMSPage; + Page3 : ShortEMSPage; + end; + + PageFramePtr = ^EMSPageFrameType; + +var + EMSFat : EMSFatTypePtr; + EMSPageFrame : PageFramePtr; + EMSSaveExitProc : Pointer; + NumInEMSFat : Word; + Pages : Array[0..3] of ^EMSPage; + CurrentMapping : record + StartPage : Word; + PagesMapped : Word; + Hand : Word; + end; + +procedure EMS_Close_All; +var + I : Word; + +begin + if not UsingEMS then Exit; + for I := 1 to NumInEMSFat do + if not DeallocateEMSHandle(EMSFat^[I].Handle) then + MSortResult := MSortEMSError; + NumInEMSFat := 0; +end; + +procedure EMS_ExitProc; +begin + ExitProc := EMSSaveExitProc; + EMS_Close_All; +end; + +function EMS_EOF(var F : File) : Boolean; + +begin + with FileRec(F) do + EMS_EOF := (Index >= ActualSize); +end; + +function PosDigit(var S : String) : Word; +Inline( + $5F/ { pop di} + $07/ { pop es} + $30/$E4/ { xor ah,ah} + $26/ { es:} + $8A/$05/ { mov al,[di]} + $89/$C1/ { mov cx,ax} + {NextChar:} + $47/ { inc di} + $26/ { es:} + $8A/$15/ { mov dl,[di]} + $80/$FA/$30/ { cmp dl,'0'} + $72/$0A/ { jb KeepLooking} + $80/$FA/$39/ { cmp dl,'9'} + $77/$05/ { ja KeepLooking} + $49/ { dec cx} + $29/$C8/ { sub ax,cx} + $EB/$04/ { jmp short ExitPoint} + {KeepLooking:} + $E2/$EB/ { loop NextChar} + $31/$C0); { xor ax,ax} + {ExitPoint:} + +function JustFilename(var PathName : string) : string; {!!.05} + {-Return just the filename of a pathname} {!!.05} +var {!!.05} + I : Word; {!!.05} +begin {!!.05} + I := Succ(Word(Length(PathName))); {!!.05} + repeat {!!.05} + Dec(I); {!!.05} + until (PathName[I] in ['\', ':', #0]) or (I = 0); {!!.05} + JustFilename := Copy(PathName, Succ(I), 64); {!!.05} +end; {!!.05} + +function ExtractNumber(var Name : PathName) : Word; {!!.05} + +var + I,P,FNum : Word; + NStr : String[3]; + FName : PathName; +begin + {find the number from the filename} + FName := JustFileName(Name); + P := PosDigit(FName); + if P <> 0 then begin + NStr := Copy(FName,P,Length(FName)); + Val(NStr,FNum,P); + if P <> 0 then + Exit; + end + else + FNum := 0; + ExtractNumber := FNum; +end; + +function FileInEMS(var Name : PathName; var FSize : LongInt; + var EMSHandle : Word; var I : Word) : Boolean; + +var + FNum : Word; + KeepLooking : Boolean; + +begin + FileInEMS := FALSE; + FNum := ExtractNumber(Name); + if FNum = 0 then + Exit; + + I := 1; + KeepLooking := TRUE; + while (KeepLooking) and (I <= NumInEMSFat) do begin + if FNum = EMSFat^[I].ID then begin + KeepLooking := FALSE; + with EMSFat^[I] do begin + FileInEMS := TRUE; + + EMSHandle := Handle; + + FSize := Size; + end; + end + else + Inc(I); + end; +end; + +function EMS_Init : Boolean; + +begin + if UseEMS and EMSInstalled and (EMSPagesAvail > 0) then + begin + EMS_Init := TRUE; + EMSPageFrame := EMSPageFramePtr; + with EMSPageFrame^ do begin + Pages[0] := @Page0; + Pages[1] := @Page1; + Pages[2] := @Page2; + Pages[3] := @Page3; + end; + NumInEMSFat := 0; + FillChar(CurrentMapping,SizeOf(CurrentMapping),0); + end + else + EMS_Init := FALSE; +end; + +function MapTheEMSPages(EMSHandle : Word; Page : Word; Index : LongInt; + Size : Word) : Word; +{***************} +var + HighPageNeeded,I,MaxPage + : Word; + MappingRequired : Boolean; + +begin + MapTheEMSPages := 0; + HighPageNeeded := ((Index + Size - 2) DIV PAGESIZE); + + with CurrentMapping do begin + Hand := EMSHandle; + PagesMapped := (HighPageNeeded - Page) + 1; + StartPage := Page; + for I := 0 to HighPageNeeded do begin + if not MapEMSPage(EMSHandle,Page+I,I) then + MSortResult := MSortEMSError; + end; + end; +end; + +procedure EMSBlockWrite(var F : File; var Rec; Size : Word; var Num : Word); + +var + PageNum,ActualIndex + : Word; + +begin + with FileRec(F) do begin + PageNum := Word(Index DIV PAGESIZE); + ActualIndex := Word(Index MOD PAGESIZE); + + PageNum := MapTheEMSPages(EMSHandle,PageNum,ActualIndex,Size); + + Move(Rec,Pages[PageNum]^[ActualIndex],Size); + Index := Index + Size; + ActualSize := ActualSize + Size; + end +end; + +procedure EMSBlockRead(var F : File; var Rec; Size : Word; var Num : Word); + +var + PageNum,ActualIndex + : Word; + I : LongInt; + +begin + with FileRec(F) do begin + PageNum := Word(Index DIV PAGESIZE); + ActualIndex := Word(Index MOD PAGESIZE); + I := Index + Size; + if Index + Size > ActualSize then begin + Size := (ActualSize - Index) + 1; + Index := Index + Size; + end + else + Index := I; + + PageNum := MapTheEMSPages(EMSHandle,PageNum,ActualIndex,Size); + + Move(Pages[PageNum]^[ActualIndex],Rec,Size); + Num := Size; + end; +end; + +procedure Open_InFile(var F : File; FName : PathName; I : Word); + +var + Hand,Ix : Word; + Sz : LongInt; + +begin + if FileInEMS(FName,Sz,Hand,Ix) and (NumInEMSFat <= EMSFILEMAX) then begin {!!.52} + with FileRec(F) do begin + Mode := fmEMS; + CurrentPage := 0; + Index := 1; + ActualSize := Sz; + EMSHandle := Hand; + end; + end + else begin + Assign(F,FName); + Reset(F,1); + MSortIOResult := IOResult; + if MSortIOResult <> 0 then + MSortResult := MSortDiskError; + BufferPos[I] := FileBufferMax + 1; + BufferSize[I] := FileBufferMax; + end; +end; + +procedure Open_OutFile(var F : File; FName : PathName; FSize : LongInt); + +var + H : Word; + SizeInPages : Word; + Avail : Word; + +begin + {before we can open a new EMS file file for Output, we must first } + {determine if enough EMS memory is avilable, if not, the file is } + {opened on disk} + SizeInPages := Word(FSize DIV PAGESIZE); + if FSize MOD PAGESIZE <> 0 then + Inc(SizeInPages); + if UsingEms then {!!.02} + Avail := EMSPagesAvail; + if UsingEMS and (NumInEMSFat < EMSFILEMAX) and (SizeInPages <= Avail) + and (SizeInPages > 0) then begin + {we have the needed space, so set up the FileRec and allocate the EMS RAM} + with FileRec(F) do begin + Mode := fmEMS; + H := AllocateEMSPages(SizeInPages); + if H = EMSErrorCode then begin + {an EMM error has occurred} + MSortResult := MSortEMSError; + Exit; + end; + NumPages := SizeInPages; + ActualSize := 0; + Inc(NumInEMSFat); + with EMSFat^[NumInEMSFat] do begin + Handle := H; + Size := FSize; + ID := ExtractNumber(FName); + end; + Name := FName; + EMSHandle := H; + CurrentPage := 0; + Index := 1; + end; + end + else begin + Assign(F,FName); + Rewrite(F,1); + BufferPos[0] := 1; + MSortIOResult := IOResult; + if MSortIOResult <> 0 then + MSortResult := MSortDiskError; + end; +end; + +procedure RemoveFromEMSFat(var F : File); + + +begin +end; + +procedure CloseEMSFile(var F : File); +var + FName : PathName; + H,Ix : Word; + Sz : LongInt; + +begin + FName := FileRec(F).Name; + if FileInEMS(FName,Sz,H,Ix) then + with EMSFat^[Ix] do + Size := FileRec(F).ActualSize; +end; + +procedure DisposeEMSFile(var F : File); + +begin + with FileRec(F) do begin + if not DeallocateEMSHandle(EMSHandle) then + MSortResult := MSortEMSError; + Mode := fmClosed; + end; + RemoveFromEMSFat(F); +end; diff --git a/src/wc_sdk/msortinf.inc b/src/wc_sdk/msortinf.inc new file mode 100644 index 0000000..4b70fd1 --- /dev/null +++ b/src/wc_sdk/msortinf.inc @@ -0,0 +1,307 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{$DEFINE Heap6} + +const + SIZETYPEMAX = 16380; + +type + SizeType = Array[1..SIZETYPEMAX] of Word; + SizeTypePtr = ^SizeType; + +function AnalyzeEMS(ST : SizeTypePtr; TableSize : Word; + RunL,RecL : Word; var PagesUsed : Word) : LongInt; +{-Find Size of items that will fit in EMS memory given the SizeTable from } +{AutoSimulate, the Run Length, Record Length, and free EMS pages.} + +var + PagesFree : Word; + PagesPerRun : Word; + Pg : Word; + Count : Word; + RunCt : Word; + AE : LongInt; + BytesPerRun : LongInt; + Continue : Boolean; + +begin + AnalyzeEMS := 0; + PagesFree := EMSPagesAvail; {get number of free pages from EMM} + if PagesFree = 0 then {if no free pages then exit} + Exit; + + PagesUsed := 0; + + {calculate the number of pages used by a single run} + BytesPerRun := LongInt(RecL) * LongInt(RunL); + PagesPerRun := Word((LongInt(BytesPerRun) + PAGESIZE - 1) DIV + LongInt(PAGESIZE)); + + {step through the size table until we either run out of EMS pages or } + { we don't need anymore space.} + Count := 1; + Continue := TRUE; + AE := 0; + while Continue and (Count <= TableSize) do begin + RunCt := ST^[Count]; + BytesPerRun := LongInt(RecL) * LongInt(RunL) * LongInt(RunCt); + PagesPerRun := Word((LongInt(BytesPerRun) + PAGESIZE - 1) DIV + LongInt(PAGESIZE)); + + Pg := PagesUsed + PagesPerRun; + if Pg <= PagesFree then begin + AE := AE + BytesPerRun; + PagesUsed := Pg; + end + else + Continue := FALSE; + Inc(Count); + end; + AnalyzeEMS := AE; +end; + +function AutoSimulate(SizeInBytes : LongInt; WillUseEMS : Boolean; + RunLen,RecLen : Word; + var EMSPagesUsed : Word; var Hands : Word) : LongInt; +{-Calculates the amount of disk space needed by simulating the merge process.} +{Accounts for EMS usage (by calling AnalyzeEMS). Since the final merge pass } +{is not merged to disk, it is not counted. This routine sets up a size table } +{on the heap, and simulates the merge process updating the size table as it } +{goes. The sum of the largest files existing on disk simultaneously is } +{calculated, and this is the largest amount of disk space needed during the } +{merge.} + +{If an error occurs, this function will return -1, otherwise the amount of } +{disk space needed in bytes is returned. } + +var + STSize : Word; + MaxST : Word; + Files,Peak,Curr : Word; + F,HighF,CurF : Word; + I : Word; + NewSize : Word; + AS : LongInt; + SizeTable : SizeTypePtr; + +begin + AutoSimulate := 0; {assume we need no disk space} + + {this tells us the number of files created by splitting the input into} + {separate files of RunLen} + F := Word((SizeInBytes DIV RecLen) + RunLen - 1) DIV RunLen; + Files := F; + HighF := F; + CurF := 1; + + {Figure out the number of file handles we need. This would never be more} + {than MERGEORDER + 1} + if F >= MERGEORDER then + Hands := MERGEORDER + else + Hands := F; + Inc(Hands); {add one for output file} + + StSize := SIZETYPEMAX * SizeOf(Word); + + if MaxAvail < (SIZETYPEMAX * SizeOf(Word)) then + StSize := Word(MaxAvail DIV SizeOf(Word)) * SizeOf(Word); + + MaxST := STSize DIV SizeOf(Word); + + GetMem(SizeTable,StSize); + FillWord(SizeTable^,MaxST,1); + + while Files > MERGEORDER do begin + Inc(HighF); {increment the high file index} + if HighF > MaxSt then begin + {we have run out of space in the SizeTable, so exit} + AutoSimulate := -1; {indicate that we were unable to calculate size} + Exit; + end; + + NewSize := 0; + + {calculate the size of the file created by merging these five files} + for I := CurF to CurF + MERGEORDER - 1 do + NewSize := NewSize + SizeTable^[I]; + + SizeTable^[HighF] := NewSize; {set the size of the high file} + Files := (Files - MERGEORDER) + 1; {decrement the files} + CurF := CurF + MERGEORDER; + end; + Peak := 0; + + for I := CurF - MERGEORDER to HighF do + Peak := Peak + SizeTable^[I]; + + + AS := LongInt(Peak) * LongInt(RunLen) * LongInt(RecLen); + if AS < SizeInBytes then + AS := SizeInBytes; + + if WillUseEMS then begin + AS := AS - AnalyzeEMS(SizeTable,HighF,RunLen,RecLen,EMSPagesUsed); + if AS < 0 then + AS := 0; + end + else + EMSPagesUsed := 0; + + FreeMem(SizeTable,StSize); + + AutoSimulate := AS; +end; + +{$IFDEF Heap6} + Function RoundToGranul ( Value : Word ) : Word; + {-Rounds Value up to the next multiple of 8} + Begin + RoundToGranul := (Value + 7) And $FFF8; + End; +{$ENDIF} + +function AutoSortInfo(FSizeInRecs : LongInt; + RecLength : Word; + var HeapSpace : LongInt; + var DiskSpace : LongInt; + var FileHandles : Word; + var EMSPages : Word; + var RunLen : Word; + var FileBufs : Word; + var OutFileBufs : Word; + var AllInMem : Boolean) : MSortStatus; +label + ExitPoint; +var + TotalNeeded,Avail,PBufLen,Temp,DiskSpaceNeeded,DiskSpaceFree,MaxAv + : LongInt; + EMSToBeUsed : Boolean; + {$IFDEF Heap6} {!!.06} + SaveRecLen : Word; + {$ELSE} + FreeMinSave : Word; {!!.04} + {$ENDIF} {!!.06} + FreeListSize : LongInt; + + +begin + AutoSortInfo := MSortSuccess; +{$IFNDEF Heap6} {!!.06} + {Set FreeMin to some reasonable value (preserving its original contents)} + FreeMinSave := FreeMin; {!!.04} + if FreeMin < UserFreeMin then {!!.04} + FreeMin := UserFreeMin; {!!.04} +{$ENDIF} {!!.06} + +{$IFDEF Heap6} + SaveRecLen := RecLength; + RecLength := RoundToGranul(RecLength); +{$ENDIF} + EMSToBeUsed := UseEMS and EMSInstalled and (EMSPagesAvail > 0); + {calculate optimum buffer sizes for RecBuf and I/O buffers} + FreeListSize := 0; + {$IFNDEF BigHeap} + {$IFNDEF Heap6} + if Ofs(FreePtr^) = 0 then + FreeListSize := 0 + else + FreeListSize := LongInt(65536)-Ofs(FreePtr^); + {$ENDIF} + {$ENDIF} + MaxAv := MaxAvail; + if MaxAv > MaxHeapToUse then + MaxAv := MaxHeapToUse; + HeapSpace := MaxAv; {!!.02} + Avail := MaxAv + {$IFNDEF BigHeap} + - FreeListSize {for free list buffer} + {$ENDIF} + - (2*RecLength) + - SizeOf(InFilePtr^) {!!.04} + {$IFNDEF Heap6} {!!.06} + - UserFreeMin + {$ENDIF} {!!.06} + - UserFree; + + if EMSToBeUsed then + Avail := Avail - SizeOf(EMSFatType); + + if Avail <= 0 then begin + AutoSortInfo := MSortOutOfMemory; + goto ExitPoint; {!!.04} + end; + + PBufLen:= (LongInt(FSizeInRecs) * SizeOf(Pointer)) + 15; {!!.04} + + TotalNeeded := (LongInt(FSizeInRecs+MERGEORDER) * RecLength) + PBufLen; + + if (TotalNeeded < Avail) and (FSizeInRecs < BiggestDataItem) then begin + {entire file will fit in memory, so no need for I/O buffers} + AllInMem := TRUE; + FileBufs := 0; + RunLen := FSizeInRecs; + Temp := Avail - TotalNeeded; + if Temp > BiggestDataItem then + Temp := BiggestDataItem; + + OutFileBufs := Temp; + end + else begin + {file won't fit in mem, so pick sizes for RunLen and FileBufs} + AllInMem := FALSE; + Temp := (Avail DIV BUFSLICE); + if Temp > BiggestDataItem then + Temp := BiggestDataItem + else if Temp < RecLength then + Temp := 0; + + OutFileBufs := Temp; + Avail := Avail - OutFileBufs; + Temp := (Avail DIV (4+RecLength)); + if Temp > LongInt(MAXRUNLENGTH) then + Temp := MAXRUNLENGTH; + RunLen := Word(Temp); + + Temp := LongInt(OutFileBufs) * 5; {!!.02} + if Temp > BiggestDataItem then + Temp := BiggestDataItem; + FileBufs := Temp; + end; + {$IFDEF Heap6} + RecLength := SaveRecLen; + {$ENDIF} + DiskSpace := AutoSimulate(FSizeInRecs * RecLength,EMSToBeUsed, + RunLen,RecLength, + EMSPages,FileHandles); +ExitPoint: +{$IFNDEF Heap6} {!!.06} + FreeMin := FreeMinSave; {!!.04} +{$ENDIF} {!!.06} +end; + diff --git a/src/wc_sdk/msortp.pas b/src/wc_sdk/msortp.pas new file mode 100644 index 0000000..721755e --- /dev/null +++ b/src/wc_sdk/msortp.pas @@ -0,0 +1,1606 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{$F-,V-,B-,S-,I-,R-,X+,A+} + +{$I btdefine.inc} + +{$IFDEF CanSetOvrflowCheck} + {$Q-} +{$ENDIF} + +{$IFDEF Ver60} + !! ERROR - cannot be compiled for Turbo Pascal 6.0 +{$ENDIF} +{$IFDEF Ver15} + !! ERROR - cannot be compiled for Turbo Pascal for Windows 1.5 +{$ENDIF} +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + + +unit MSortP; + {-Merge sort unit. Requires BP7 (rmode, pmode, Windows)} + +interface + +uses +{$IFDEF Windows} + WinTypes, + WinProcs, +{$ENDIF} +{$IFDEF DPMI} + WinApi, +{$ENDIF} +{$IFDEF Ver80} {!!.51} + SysUtils; {!!.51} +{$ELSE} {!!.51} + Strings; +{$ENDIF} {!!.51} + +const + MinRecsPerRun = 4; {Minimum number of records in run buffer} + MergeOrder = 5; {Input files used at a time during merge, >=2, <=10} + MaxSelectors = 256; {Maximum number of selectors allocated} + SwapThreshold = 64; {RecLen at least this big causes pointer swap} + MedianThreshold = 16; {Threshold for using median-of-three quicksort} + +type + ElementIOProc = procedure; + ElementCompareFunc = function (var X, Y) : Boolean; + MergeNameFunc = function (Dest : PChar; MergeNum : Word) : PChar; + + MergeInfoRec = + record {Record returned by MergeInfo} + SortStatus : Word; {Predicted status of sort, assuming disk ok} + MergeFiles : Word; {Total number of merge files created} + MergeHandles : Word; {Maximum file handles used} + MergePhases : Word; {Number of merge phases} + MaxDiskSpace : LongInt; {Maximum peak disk space used} + HeapUsed : LongInt; {Heap space actually used} + SelectorCount: Word; {Number of selectors allocated} + RecsPerSel : Word; {Records stored in each selector} + end; + + function MergeSort(MaxHeapToUse : LongInt; + RecLen : Word; + SendToSortEngine : ElementIOProc; + Less : ElementCompareFunc; + GetFromSortEngine : ElementIOProc; + MergeName : MergeNameFunc) : Word; + {-Sorts elements of size RecLen. Uses no more than MaxHeapToUse + bytes of heap space. Elements are passed into MergeSort by the + user-defined SendToSortEngine routine. Elements are compared by + the user-defined Less routine. Sorted elements are passed back + to the program by the user-defined GetFromSortEngine routine. + When merge files must be used, the name and location of each + merge file is determined by the user-defined MergeName routine. + MergeSort returns a status code: + 0 success + 1 user abort + 8 insufficient memory to sort + 106 invalid input parameter + (RecLen zero, MaxHeapToUse too small) + 204 invalid pointer returned by GlobalLock, or + SelectorInc <> 8 + 213 no elements available to sort + 214 more than 65535 merge files + else DOS or Turbo Pascal error code} + + function PutElement(var X) : Boolean; + {-Submits an element to the sort system. Returns True if the record + is successfully submitted.} + + function GetElement(var X) : Boolean; + {-Returns next record in sorted order. Returns True while there are + more records to return. When it returns False, X is uninitialized.} + + function DefaultMergeName(Dest : PChar; MergeNum : Word) : PChar; + {-Returns a default name for each merge file (SORnnnnn.TMP)} + + procedure AbortSort; + {-Call this routine from Less, SendToSortEngine, or GetFromSortEngine + to abort the sort. The Less function must always return False + if it calls AbortSort.} + + function OptimumHeapToUse(RecLen : Word; NumRecs : LongInt) : LongInt; + {-Returns the optimum amount of heap space to sort NumRecs records + of RecLen bytes each. Less heap space causes merging; more heap + space is partially unused.} + + function MinimumHeapToUse(RecLen : Word) : LongInt; + {-Returns the absolute minimum heap that allows MergeSort to succeed} + + procedure MergeInfo(MaxHeapToUse : LongInt; + RecLen : Word; + NumRecs : LongInt; + var MI : MergeInfoRec); + {-Predicts status and resource usage of a merge sort. See + MergeInfoRec above for the information returned. Returns + MI.MaxDiskSpace = -1 in the rare case where disk space analysis + cannot be performed.} + + + procedure InitMergeSort(MaxHeapToUse : LongInt; + RecLen : Word; + Less : ElementCompareFunc; + MergeName : MergeNameFunc); + {-Initialize merge sort, for non-callback method of sorting} + + procedure DoneMergeSort; + {-Clean up after merge sort, for non-callback method of sorting} + + function GetSortStatus : Word; + {-Return sort status variable, useful with non-callback sorting} + + {==================================================================} + +implementation + +type + OS = + record {Convenient typecast} + O : Word; + S : Word; + end; + PointerPtr = ^Pointer; {Pointer to pointer} + ElementPtrFunc = + function (ElNum : LongInt) : Pointer; {Return address of given element} + SwapElementProc = + procedure (Pl, Pr : LongInt); {Swap two elements} + + MergeWordArray = + array[1..MergeOrder] of Word; {Handles of open merge files} + MergePtrArray = + array[1..MergeOrder] of Pointer; {Used for managing head elements} + SelectorArray = + array[0..MaxSelectors-1] of Word; {Used for managing the run buffer} + PathArray = + array[0..79] of Char; {Used for buffering a pathname} + +var + SortStatus : Word; {Current status of sort} + TotalCount : LongInt; {Total elements sorted} + + {Variables related to memory management} + Selectors : SelectorArray; {Selectors for global work area} + SelectorCount : Word; {Number of selectors allocated} + DSelectorCount : Word; {Number of selectors for run data} + RecsPerSel : Word; {Number of records mapped by one selector} + RecsShr : Word; {SHR count corresponding to RecsPerSel} + RecsMask : Word; {AND mask corresponding to RecsPerSel} + RecordLen : Word; {Bytes in each data record} + RecordLenAlloc : Word; {Bytes in each data record buffer} + SwapPointers : WordBool; {True when swapping pointers} + + {Variables related to run sorting} + AllocatedRecs : LongInt; {Total records allocated in global buffer} + RunCapacity : LongInt; {Capacity (in records) of run buffer} + RunCount : LongInt; {Current number of records in run buffer} + RunElement : LongInt; {Last run element passed back to user} + PivotPtr : Pointer; {Pointer to pivot record} + SwapPtr : Pointer; {Pointer to record swap area} + LessF : ElementCompareFunc; {User less function} + ElementPtrF : ElementPtrFunc; {Element pointer function} + SwapElementP : SwapElementProc; {Swap element procedure} + + {Variables related to merging} + MergeNameF : MergeNameFunc; {User merge filename function} + MergeFileCount : Word; {Number of merge files created} + MergeFileMerged : Word; {Index of last merge file merged} + MergeOpenCount : Word; {Count of open merge files} + MergeBufSize : Word; {Usable bytes in merge buffer} + MergeFileNumber : MergeWordArray; {File number of each open merge file} + MergeFiles : MergeWordArray; {File handles for merge files} + MergeSelectors : MergeWordArray; {Selectors for each merge buffer} + MergeBytesLoaded : MergeWordArray; {Count of bytes in each merge buffer} + MergeBytesUsed : MergeWordArray; {Bytes used in each merge buffer} + MergePtrs : MergePtrArray; {Current head elements in each merge buffer} + OutFile : Word; {Output file handle} + OutSelector : Word; {Selector for output buffer} + OutBytesUsed : Word; {Number of bytes in output buffer} + + FirstCallToGetElement : Boolean; {True until GetElement called once} + + {$DEFINE UseAsm} {Undefine only for testing} + +{$IFNDEF DPMI} +{$IFNDEF Windows} + {Emulate a couple of memory allocation functions. These + work only if Bytes < 65511, which is always true here. + Requires the heap manager of TP6 or later.} + + const + gmem_Moveable = $0002; { Allocate moveable memory } + + type + THandle = Word; + + function HeapFunc(Size : Word) : Integer; far; + {-Return nil pointer if insufficient memory} + begin + if Size <> 0 then + HeapFunc := 1; + end; + + function GlobalAlloc(Flags : Word; Bytes : Longint) : THandle; + var + Alloc : Longint; + P : Pointer; + SaveHeapError : Pointer; + begin + Alloc := Bytes+16; + if Alloc > 65527 then + GlobalAlloc := 0 + else begin + SaveHeapError := HeapError; + HeapError := @HeapFunc; + GetMem(P, Alloc); + if P = nil then + GlobalAlloc := 0 + else begin + GlobalAlloc := OS(P).S+1; + Pointer(Ptr(OS(P).S, 8)^) := P; + LongInt(Ptr(OS(P).S, 12)^) := Alloc; + end; + HeapError := SaveHeapError; + end; + end; + + function GlobalFree(H : THandle) : THandle; + var + Alloc : Longint; + P : Pointer; + begin + if H <> 0 then begin + dec(H); + P := Pointer(Ptr(H, 8)^); + Alloc := LongInt(Ptr(H, 12)^); + FreeMem(P, Alloc); + end; + GlobalFree := 0; + end; +{$ENDIF} +{$ENDIF} + + function CreateFile(FName : PChar; var Handle : Word) : Word; assembler; + {-Create a file, returning status code and open handle} + asm + push ds + lds dx,FName + mov ah,$3C + xor cx,cx + int $21 + jc @Done + les di,Handle + mov es:[di],ax + xor ax,ax +@Done: + pop ds + end; + + function OpenFile(FName : PChar; var Handle : Word) : Word; assembler; + {-Open file read-only, returning status code and open handle} + asm + push ds + lds dx,FName + mov ax,$3D00 {read only} + int $21 + jc @Done + les di,Handle + mov es:[di],ax + xor ax,ax +@Done: + pop ds + end; + + function BlockWriteFile(Handle : Word; var Buf; BufLen : Word) : Word; assembler; + {-Write buffer to file, returning status} + asm + push ds + mov bx,Handle + mov cx,BufLen + lds dx,Buf + mov ah,$40 + int $21 + jc @Done + cmp ax,cx + mov ax,101 {disk full} + jne @Done + xor ax,ax +@Done: + pop ds + end; + + function BlockReadFile(Handle : Word; var Buf; + BufLen : Word; var Len : Word) : Word; assembler; + {-Read buffer from file, returning status and bytes read} + asm + push ds + mov bx,Handle + mov cx,BufLen + lds dx,Buf + mov ah,$3F + int $21 + jc @Done + les di,Len + mov es:[di],ax + xor ax,ax +@Done: + pop ds + end; + + function CloseFile(Handle : Word) : Word; assembler; + {-Close file, returning status} + asm + mov bx,Handle + mov ah,$3E + int $21 + jc @Done + xor ax,ax +@Done: + end; + + function DeleteFile(FName : PChar) : Word; assembler; + {-Delete closed file, returning status} + asm + push ds + lds dx,FName + mov ah,$41 + int $21 + jc @Done + xor ax,ax +@Done: + pop ds + end; + + function ElementPtrDirect(ElNum : LongInt) : Pointer; far; + {-Return pointer to given element in the global buffer} + {$IFDEF UseAsm} + assembler; + asm + mov ax,word ptr ElNum + mov dx,word ptr ElNum+2 + mov si,ax {Save low word of ElNum} + mov cl,byte ptr RecsShr + + {The following stuff circumvents the use of a 32-bit shift} + cmp cl,8 {RecordLenAlloc > 256 bytes?} + jb @2 {Jump if so} + cmp cl,16 {RecordLenAlloc = 1 byte?} + jne @1 {Jump if not} + mov ax,dx {RecordLenAlloc = 1 byte} + jmp @3 +@1: mov al,ah {RecordLenAlloc <= 256 bytes} + mov ah,dl + sub cl,8 +@2: shr ax,cl + +@3: shl ax,1 {ax = selector offset} + mov bx,ax {bx = offset into Selectors} + mov ax,RecsMask {ax = offset mask} + and ax,si {ax = OS(ElNum).O and RecsMask} + mul word ptr RecordLenAlloc {ax = data offset} + mov dx,word ptr Selectors[bx] {dx:ax = address} + end; + {$ELSE} + begin + ElementPtrDirect := Ptr(Selectors[ElNum shr byte(RecsShr)], + (OS(ElNum).O and RecsMask)*RecordLenAlloc); + end; + {$ENDIF} + + function ElementPtrIndirect(ElNum : LongInt) : Pointer; far; + {-Return pointer to element, assuming that first four bytes + of buffer are another pointer} + {$IFDEF UseAsm} + assembler; + asm + mov ax,word ptr ElNum + mov dx,word ptr ElNum+2 + mov si,ax + mov cl,byte ptr RecsShr + cmp cl,8 + jb @2 + cmp cl,16 + jne @1 + mov ax,dx + jmp @3 +@1: mov al,ah + mov ah,dl + sub cl,8 +@2: shr ax,cl +@3: shl ax,1 + mov bx,ax + mov ax,RecsMask + and ax,si + mul word ptr RecordLenAlloc + mov di,ax + mov es,word ptr Selectors[bx] + les ax,es:[di] + mov dx,es + end; + {$ELSE} + begin + ElementPtrIndirect := PointerPtr(Ptr(Selectors[ElNum shr byte(RecsShr)], + (OS(ElNum).O and RecsMask)*RecordLenAlloc))^; + end; + {$ENDIF} + + procedure MoveElement(SPtr, DPtr : Pointer); assembler; + {-Move one element into another. Assumes SPtr <> DPtr} + asm + mov dx,ds + mov cx,RecordLen + lds si,SPtr + les di,DPtr + cld + shr cx,1 + rep movsw + rcl cx,1 + rep movsb + mov ds,dx + end; + + procedure SwapElementsDirect(Pl, Pr : LongInt); far; + {-Swap data of elements} + var + LPtr : Pointer; + RPtr : Pointer; + begin + LPtr := ElementPtrDirect(Pl); + RPtr := ElementPtrDirect(Pr); + MoveElement(LPtr, SwapPtr); + MoveElement(RPtr, LPtr); + MoveElement(SwapPtr, RPtr); + end; + + procedure SwapElementPtrs(Pl, Pr : LongInt); far; + {-Swap element pointers} + {$IFDEF UseAsm} + assembler; + asm + push word ptr Pl+2 + push word ptr Pl + call ElementPtrDirect + push dx {Save result} + push ax + push word ptr Pr+2 + push word ptr Pr + call ElementPtrDirect + mov bx,ds + mov es,dx + mov di,ax {es:di -> RPtr} + pop si + pop ds {ds:si -> LPtr} + mov ax,es:[di] + mov dx,es:[di+2] + xchg ax,ds:[si] + xchg dx,ds:[si+2] + mov es:[di],ax + mov es:[di+2],dx + mov ds,bx + end; + {$ELSE} + var + LPtr : PointerPtr; + RPtr : PointerPtr; + TPtr : Pointer; + begin + LPtr := ElementPtrDirect(Pl); + RPtr := ElementPtrDirect(Pr); + TPtr := LPtr^; + LPtr^ := RPtr^; + RPtr^ := TPtr; + end; + {$ENDIF} + + procedure QuickSort(L, R : LongInt); + {-Non-recursive in-memory quicksort} + const + StackSize = 32; + type + Stack = array[1..StackSize] of LongInt; + var + Pl : LongInt; {Left edge within partition} + Pr : LongInt; {Right edge within partition} + Pm : LongInt; {Mid-point of partition} + PartitionLen : LongInt; {Size of current partition} + StackP : Integer; {Stack pointer} + Lstack : Stack; {Pending partitions, left edge} + Rstack : Stack; {Pending partitions, right edge} + begin + {Initialize the stack} + StackP := 1; + Lstack[1] := L; + Rstack[1] := R; + + {Repeatedly take top partition from stack} + repeat + + {Pop the stack} + L := Lstack[StackP]; + R := Rstack[StackP]; + Dec(StackP); + + {Sort current partition} + repeat + + {!!.42, partitioning methods improved} + + Pl := L; + Pr := R; + PartitionLen := Pr-Pl+1; + + {Select one of the three partitioning methods} + {Median is on average fastest, and quite safe} + {Midpoint is simplest, but may degrade on some data sets} + {Random is the safest, but on average the slowest} + {$DEFINE Median} + {.$DEFINE MidPoint} + {.$DEFINE Random} + + {$IFDEF MidPoint} + Pm := Pl+(PartitionLen shr 1); + {$ENDIF} + + {$IFDEF Random} + Pm := Pl+Random(PartitionLen); + {$ENDIF} + + {$IFDEF Median} + Pm := Pl+(PartitionLen shr 1); + if PartitionLen >= MedianThreshold then begin + {Sort elements Pl, Pm, Pr} + if LessF(ElementPtrF(Pm)^, ElementPtrF(Pl)^) then + SwapElementP(Pm, Pl); + if LessF(ElementPtrF(Pr)^, ElementPtrF(Pl)^) then + SwapElementP(Pr, Pl); + if LessF(ElementPtrF(Pr)^, ElementPtrF(Pm)^) then + SwapElementP(Pr, Pm); + + {Exchange Pm with Pr-1 but use Pm's value as the pivot} + SwapElementP(Pm, Pr-1); + Pm := Pr-1; + + {Reduce range of swapping} + inc(Pl); + dec(Pr, 2); + end; + {$ENDIF} + + {Save the pivot element} + MoveElement(ElementPtrF(Pm), PivotPtr); + + {Swap items in sort order around the pivot} + repeat + {$IFDEF UseAsm} + asm +@0: push word ptr Pl+2 + push word ptr Pl + call dword ptr ElementPtrF + push dx + push ax + push word ptr PivotPtr+2 + push word ptr PivotPtr + call dword ptr LessF + or al,al + jz @1 + add word ptr Pl,1 + adc word ptr Pl+2,0 + jmp @0 +@1: push word ptr Pr+2 + push word ptr Pr + call dword ptr ElementPtrF + push word ptr PivotPtr+2 + push word ptr PivotPtr + push dx + push ax + call dword ptr LessF + or al,al + jz @2 + sub word ptr Pr,1 + sbb word ptr Pr+2,0 + jmp @1 +@2: end; + {$ELSE} + while LessF(ElementPtrF(Pl)^, PivotPtr^) do + Inc(Pl); + while LessF(PivotPtr^, ElementPtrF(Pr)^) do + Dec(Pr); + {$ENDIF} + + {Check for user abort} + if SortStatus <> 0 then + Exit; + + if Pl = Pr then begin + {Reached the pivot} + Inc(Pl); + Dec(Pr); + end else if Pl < Pr then begin + {Swap elements around the pivot} + SwapElementP(Pl, Pr); + Inc(Pl); + Dec(Pr); + end; + until Pl > Pr; + + {Decide which partition to sort next} + if (Pr-L) < (R-Pl) then begin + {Left partition is bigger} + if Pl < R then begin + {Stack the request for sorting right partition} + Inc(StackP); + Lstack[StackP] := Pl; + Rstack[StackP] := R; + end; + {Continue sorting left partition} + R := Pr; + end else begin + {Right partition is bigger} + if L < Pr then begin + {Stack the request for sorting left partition} + Inc(StackP); + Lstack[StackP] := L; + Rstack[StackP] := Pr; + end; + {Continue sorting right partition} + L := Pl; + end; + + until L >= R; + until StackP <= 0; + end; + + procedure CreateNewMergeFile(var Handle : Word); + {-Create a new merge file} + var + FName : PathArray; + begin + if MergeFileCount = 65535 then begin + {Too many merge files} + SortStatus := 214; + Exit; + end; + + {Create new merge file} + inc(MergeFileCount); + SortStatus := CreateFile(MergeNameF(FName, MergeFileCount), Handle); + if SortStatus <> 0 then + dec(MergeFileCount); + end; + + procedure FlushOutBuffer; + {-Write the merge output buffer to disk} + begin + if OutBytesUsed <> 0 then + SortStatus := BlockWriteFile(OutFile, Mem[OutSelector:0], OutBytesUsed); + end; + + procedure StoreElement(ElPtr : Pointer); + {-Store element in the merge output buffer} + begin + if OutBytesUsed >= MergeBufSize then begin + FlushOutBuffer; + if SortStatus <> 0 then + Exit; + OutBytesUsed := 0; + end; + MoveElement(ElPtr, Ptr(OutSelector, OutBytesUsed)); + inc(OutBytesUsed, RecordLen); + end; + + procedure StoreNewMergeFile; + {-Create a new merge file and store run buffer to it} + label + ExitPoint; + var + SelNum : Word; + BytesLeft : LongInt; + BytesToWrite : LongInt; + ElNum : LongInt; + TempStatus : Word; + begin + {Create new merge file} + CreateNewMergeFile(OutFile); + if SortStatus <> 0 then + Exit; + + if SwapPointers then begin + {Write the run buffer element by element using pointer indirection} + OutBytesUsed := 0; + OutSelector := Selectors[DSelectorCount]; + for ElNum := 0 to RunCount-1 do begin + StoreElement(ElementPtrIndirect(ElNum)); + if SortStatus <> 0 then + goto ExitPoint; + end; + FlushOutBuffer; + + end else begin + {Write the run buffer by blocks to the merge file} + BytesLeft := RunCount*RecordLen; + BytesToWrite := MergeBufSize; + SelNum := 0; + while BytesLeft > 0 do begin + OutSelector := Selectors[SelNum]; + if BytesLeft < BytesToWrite then + BytesToWrite := BytesLeft; + SortStatus := BlockWriteFile(OutFile, Mem[OutSelector:0], BytesToWrite); + if SortStatus <> 0 then + BytesLeft := 0 + {Note: all merge files are deleted in MergeSort} + else begin + dec(BytesLeft, BytesToWrite); + inc(SelNum); + end; + end; + end; + +ExitPoint: + {Close merge file} + TempStatus := CloseFile(OutFile); + if SortStatus = 0 then + SortStatus := TempStatus; + end; + + procedure GetMergeElementPtr(M : Word); + {-Get pointer to next valid element of specified open merge file} + var + Len : Word; + TempStatus : Word; + FName : PathArray; + begin + if MergeBytesUsed[M] >= MergeBytesLoaded[M] then begin + {Try to load new data into buffer} + SortStatus := BlockReadFile(MergeFiles[M], Mem[MergeSelectors[M]:0], + MergeBufSize, Len); + if (SortStatus <> 0) or (Len < RecordLen) then begin + {Error reading file or end of file. Close and delete it} + TempStatus := CloseFile(MergeFiles[M]); + TempStatus := DeleteFile(MergeNameF(FName, MergeFileNumber[M])); + {Remove file from merge list} + if M <> MergeOpenCount then begin + MergeFileNumber[M] := MergeFileNumber[MergeOpenCount]; + MergeFiles[M] := MergeFiles[MergeOpenCount]; + MergeSelectors[M] := MergeSelectors[MergeOpenCount]; + MergeBytesLoaded[M] := MergeBytesLoaded[MergeOpenCount]; + MergeBytesUsed[M] := MergeBytesUsed[MergeOpenCount]; + MergePtrs[M] := MergePtrs[MergeOpenCount]; + end; + dec(MergeOpenCount); + Exit; + end; + MergeBytesLoaded[M] := Len; + MergeBytesUsed[M] := 0; + end; + + OS(MergePtrs[M]).O := MergeBytesUsed[M]; + inc(MergeBytesUsed[M], RecordLen); + end; + + procedure OpenMergeFiles; + {-Open next group of merge files (up to MergeOrder of them)} + var + FName : PathArray; + begin + MergeOpenCount := 0; + while (MergeOpenCount < MergeOrder) and (MergeFileMerged < MergeFileCount) do begin + {MergeOpenCount counts the number of open merge files} + inc(MergeOpenCount); + {Open associated merge file} + inc(MergeFileMerged); + SortStatus := OpenFile(MergeNameF(FName, MergeFileMerged), MergeFiles[MergeOpenCount]); + if SortStatus <> 0 then begin + dec(MergeFileMerged); + dec(MergeOpenCount); + Exit; + end; + {File number of merge file} + MergeFileNumber[MergeOpenCount] := MergeFileMerged; + {Selector for merge file} + MergeSelectors[MergeOpenCount] := Selectors[MergeOpenCount-1]; + {Number of bytes currently in merge buffer} + MergeBytesLoaded[MergeOpenCount] := 0; + {Number of bytes used in merge buffer} + MergeBytesUsed[MergeOpenCount] := 0; + {Save the segment of the merge pointer} + OS(MergePtrs[MergeOpenCount]).S := MergeSelectors[MergeOpenCount]; + {Get the first element} + GetMergeElementPtr(MergeOpenCount); + if SortStatus <> 0 then + Exit; + end; + end; + + function GetNextElementIndex : Word; + {-Return merge index of next element in sorted order, nil if error or none} + {$IFDEF UseAsm} + assembler; + var + MinElPtr : Pointer; + asm + {Get out fast if 0 or 1 merge files left open} + xor ax,ax + mov cx,MergeOpenCount + jcxz @3 + inc ax + cmp cx,2 + jb @3 + + {Assume first element is the least} + les di,dword ptr MergePtrs + mov word ptr MinElPtr,di + mov word ptr MinElPtr+2,es + mov bx,2 + + {Loop to find minimum element} +@1: push ax {save result} + push bx {save loop index} + shl bx,1 + shl bx,1 + les di,dword ptr MergePtrs[bx-4] + push es {save MergePtrs[M]} + push di + push es + push di + les di,MinElPtr + push es + push di + call dword ptr LessF + or al,al + pop di + pop es + pop bx + pop ax + jz @2 + mov ax,bx + mov word ptr MinElPtr,di + mov word ptr MinElPtr+2,es +@2: inc bx + cmp bx,MergeOpenCount + jbe @1 +@3: + end; + {$ELSE} + var + M : Word; + MinElPtr : Pointer; + begin + if MergeOpenCount = 0 then begin + {All merge streams are empty} + GetNextElementIndex := 0; + Exit; + end; + + {Assume first element is the least} + MinElPtr := MergePtrs[1]; + GetNextElementIndex := 1; + + {Scan the other elements} + for M := 2 to MergeOpenCount do + if LessF(MergePtrs[M]^, MinElPtr^) then begin + GetNextElementIndex := M; + MinElPtr := MergePtrs[M]; + end; + end; + {$ENDIF} + + procedure MergeFileGroup; + {-Merge the opened merge files into the output} + var + NextElementIndex : Word; + TempStatus : Word; + Done : WordBool; + begin + Done := False; + repeat + {Find index of minimum element} + NextElementIndex := GetNextElementIndex; + if SortStatus <> 0 then + Done := True + else if NextElementIndex = 0 then + Done := True + else begin + {Copy element to output} + StoreElement(MergePtrs[NextElementIndex]); + if SortStatus <> 0 then + Done := True + else + {Get the next element from its merge stream} + GetMergeElementPtr(NextElementIndex); + end; + until Done; + + {Flush and close the output file} + if SortStatus = 0 then + FlushOutBuffer; + TempStatus := CloseFile(OutFile); + if SortStatus = 0 then + SortStatus := TempStatus; + end; + + procedure PrimaryMerge; + {-Merge until there are no more than MergeOrder merge files left} + begin + OutSelector := Selectors[MergeOrder]; + while (SortStatus = 0) and (MergeFileCount-MergeFileMerged > MergeOrder) do begin + {Open next group of MergeOrder files} + OpenMergeFiles; + if SortStatus = 0 then begin + {Create new output file} + CreateNewMergeFile(OutFile); + if SortStatus = 0 then begin + {Merge these files into the output} + OutBytesUsed := 0; + MergeFileGroup; + end; + end; + end; + end; + + procedure DeleteRemainingFiles; + {-Delete any remaining merge files. Needed only in case of error} + var + TempStatus : Word; + I : Word; + FName : PathArray; + begin + {!!.42 Delete any merge files currently open} + for I := 1 to MergeOpenCount do begin + TempStatus := CloseFile(MergeFiles[I]); + TempStatus := DeleteFile(MergeNameF(FName, MergeFileNumber[I])); + end; + + for I := MergeFileMerged+1 to MergeFileCount do + TempStatus := DeleteFile(MergeNameF(FName, I)); + end; + + {$IFDEF Windows} + procedure AHIncr; far; external 'KERNEL' index 114; + {-Magic routine for getting the constant to add to scan >64K blocks} + {$ENDIF} + + function ValidateInput(RecLen : Word) : Word; + {-Validate the input parameters} + begin + {Validate SelectorInc (8 assumed throughout)} + {$IFDEF DPMI} + if SelectorInc <> 8 then begin + ValidateInput := 204; + Exit; + end; + {$ENDIF} + {$IFDEF Windows} + if Ofs(AHIncr) <> 8 then begin + ValidateInput := 204; + Exit; + end; + {$ENDIF} + + if RecLen = 0 then begin + ValidateInput := 106; + Exit; + end; + + ValidateInput := 0; + end; + + procedure FreeAllHandles; + {-Free all allocated memory (in handle format)} + var + SelNum : Word; + begin + if SelectorCount > 0 then + for SelNum := 0 to SelectorCount-1 do + GlobalFree(Selectors[SelNum]); + end; + + function HandlesToSelectors : Word; + {-Convert handles to selectors} + var + SelNum : Word; + SelectorP : Pointer; + TempSelectors : SelectorArray; + begin + {$IFDEF Windows} + for SelNum := 0 to SelectorCount-1 do begin + SelectorP := GlobalLock(Selectors[SelNum]); + if (SelectorP = nil) or (OS(SelectorP).O <> 0) then begin + FreeAllHandles; + HandlesToSelectors := 204; + Exit; + end; + TempSelectors[SelNum] := OS(SelectorP).S; + end; + + {All succeeded} + move(TempSelectors, Selectors, SelectorCount*SizeOf(Word)); + {$ENDIF} + HandlesToSelectors := 0; + end; + + procedure SelectorsToHandles; + var + Handle : THandle; + SelNum : Word; + begin + {$IFDEF Windows} + for SelNum := 0 to SelectorCount-1 do begin + Handle := Selectors[SelNum]; + GlobalUnlock(Handle); + Selectors[SelNum] := GlobalHandle(Handle); + end; + {$ENDIF} + end; + + procedure GetMaxRecsPerSel(RecLen : Word); + {-Compute maximum RecsPerSel and RecsShr for given RecLen} + var + R : LongInt; + begin + R := 1; + RecsShr := 0; + while R*RecLen < 65536 do begin + R := R shl 1; + inc(RecsShr); + end; + if RecsShr > 0 then begin + R := R shr 1; + dec(RecsShr); + end; + RecsPerSel := R; + end; + + function GetHandles(RecLen : Word; MaxHeapToUse : LongInt) : Word; + {-Compute segment sizes and allocate memory} + var + Handle : THandle; + InitAvail : LongInt; + SegmentSize : Word; + TooMuchHeapUsed : WordBool; + begin + {Swap elements or pointers?} + SwapPointers := (RecLen >= SwapThreshold) and + (RecLen <= 65535-SizeOf(Pointer)); + + {Adjust for pointer swapping} + RecordLen := RecLen; + if SwapPointers then begin + {Allocate an extra pointer for each record and swap just the pointers} + RecordLenAlloc := RecordLen+SizeOf(Pointer); + ElementPtrF := ElementPtrIndirect; + SwapElementP := SwapElementPtrs; + end else begin + RecordLenAlloc := RecordLen; + ElementPtrF := ElementPtrDirect; + SwapElementP := SwapElementsDirect; + end; + + {Compute largest power-of-two number of recs that fit into 64K} + GetMaxRecsPerSel(RecordLenAlloc); + + {Search for valid combinations of selectors} + repeat + {Allocate as many handles as possible in memory given} + SelectorCount := 0; + InitAvail := MemAvail; + repeat + {Allocate next handle} + Handle := GlobalAlloc(gmem_Moveable, RecsPerSel*RecordLenAlloc); + Selectors[SelectorCount] := Handle; + inc(SelectorCount); + TooMuchHeapUsed := (InitAvail-MemAvail > MaxHeapToUse); + until (SelectorCount = MaxSelectors) or (Handle = 0) or TooMuchHeapUsed; + + if TooMuchHeapUsed then begin + {Deallocate last handle to keep within heap quota} + Handle := GlobalFree(Handle); + dec(SelectorCount); + {If we fail, it's because MaxHeapToUse was too small} + GetHandles := 106; + end else if Handle = 0 then begin + {Last handle wasn't allocated} + dec(SelectorCount); + {If we fail, it's because there was insufficient heap space} + GetHandles := 8; + end; + + if SelectorCount < MergeOrder+1 then begin + {Not enough selectors, cut segment size in two} + FreeAllHandles; + RecsPerSel := RecsPerSel shr 1; + dec(RecsShr); + end; + until (SelectorCount >= MergeOrder+1) or (RecsPerSel = 0); + + if RecsPerSel = 0 then + {No way to get enough buffers} + Exit; + + RecsMask := RecsPerSel-1; + SegmentSize := RecsPerSel*RecordLenAlloc; + MergeBufSize := (SegmentSize div RecordLen)*RecordLen; + + if SwapPointers then begin + {Last segment reserved for sorted run output buffer} + DSelectorCount := SelectorCount-1; + AllocatedRecs := LongInt(RecsPerSel)*DSelectorCount; + {PivotPtr := ElementPtrDirect(AllocatedRecs-1);} {!!.50} + {inc(OS(PivotPtr).O, SizeOf(Pointer));} {!!.50} + RunCapacity := AllocatedRecs-1; + end else begin + DSelectorCount := SelectorCount; + AllocatedRecs := LongInt(RecsPerSel)*DSelectorCount; + {PivotPtr := ElementPtrDirect(AllocatedRecs-1);} {!!.50} + {SwapPtr := ElementPtrDirect(AllocatedRecs-2);} {!!.50} + RunCapacity := AllocatedRecs-2; + end; + + if RunCapacity < MinRecsPerRun then begin + {No way to get enough memory in enough buffers} + FreeAllHandles; + Exit; + end; + + GetHandles := 0; + end; + + procedure AssignPivotAndSwap; {!!.50} + {-Compute PivotPtr and SwapPtr for the current sort} + begin + if SwapPointers then begin + PivotPtr := ElementPtrDirect(AllocatedRecs-1); + inc(OS(PivotPtr).O, SizeOf(Pointer)); + SwapPtr := nil; + end else begin + PivotPtr := ElementPtrDirect(AllocatedRecs-1); + SwapPtr := ElementPtrDirect(AllocatedRecs-2); + end; + end; + + procedure InitMergeSort(MaxHeapToUse : LongInt; + RecLen : Word; + Less : ElementCompareFunc; + MergeName : MergeNameFunc); + begin + {Validate input parameters} + SortStatus := ValidateInput(RecLen); + + {Compute selector sizes and allocate buffers} + if SortStatus = 0 then + SortStatus := GetHandles(RecLen, MaxHeapToUse); + + {Convert handles to selectors} + if SortStatus = 0 then + SortStatus := HandlesToSelectors; + + {Get out if any error occurred} + if SortStatus <> 0 then + Exit; + + {Compute PivotPtr and SwapPtr} {!!.50} + AssignPivotAndSwap; {!!.50} + + {Copy parameters to global variables and initialize other globals} + LessF := Less; + MergeNameF := MergeName; + RunCount := 0; + TotalCount := 0; + MergeFileCount := 0; + MergeFileMerged := 0; + FirstCallToGetElement := True; + end; + + procedure DoneMergeSort; + begin + {Assure all merge files are gone} + DeleteRemainingFiles; + + {Free global data} + SelectorsToHandles; + FreeAllHandles; + end; + + function MergeSort(MaxHeapToUse : LongInt; + RecLen : Word; + SendToSortEngine : ElementIOProc; + Less : ElementCompareFunc; + GetFromSortEngine : ElementIOProc; + MergeName : MergeNameFunc) : Word; + begin + {initialize the merge sort} + InitMergeSort(MaxHeapToUse, RecLen, Less, MergeName); + + if SortStatus = 0 then begin + {Get all the elements from the user} + SendToSortEngine; + + if SortStatus = 0 then + {Pass elements back to the user} + GetFromSortEngine; + + {Perform final clean up and shut down the sort} + DoneMergeSort; + end; + + {Return status} + MergeSort := SortStatus; + end; + + function PutElement(var X) : Boolean; + var + SwapPtr : PointerPtr; + DataPtr : Pointer; + begin + if SortStatus <> 0 then begin + PutElement := False; + Exit; + end; + + if RunCount >= RunCapacity then begin + {Sort run buffer} + QuickSort(0, RunCount-1); + {Store to merge file} + StoreNewMergeFile; + if SortStatus <> 0 then begin + {File operation failed} + PutElement := False; + Exit; + end; + Inc(TotalCount, RunCount); + RunCount := 0; + end; + + {Store the element in the run buffer} + if SwapPointers then begin + SwapPtr := ElementPtrDirect(RunCount); + DataPtr := Ptr(OS(SwapPtr).S, OS(SwapPtr).O+SizeOf(Pointer)); + SwapPtr^ := DataPtr; + end else + DataPtr := ElementPtrDirect(RunCount); + + MoveElement(@X, DataPtr); + Inc(RunCount); + PutElement := True; + end; + + function GetElement(var X) : Boolean; + var + NextElementIndex : Word; + begin + {if first call to get element, then perform final sorting} + if FirstCallToGetElement then begin + Inc(TotalCount, RunCount); + if TotalCount = 0 then + SortStatus := 213; + + if SortStatus = 0 then + if RunCount > 0 then begin + {Sort the last run buffer} + QuickSort(0, RunCount-1); + if MergeFileCount > 0 then + {There's already a merge file, create another} + StoreNewMergeFile; + end; + + if SortStatus = 0 then + if MergeFileCount > 0 then begin + {Perform primary merging} + PrimaryMerge; + if SortStatus = 0 then + {Open the last group of files} + OpenMergeFiles; + end else + {Prepare to return elements from run buffer} + RunElement := 0; + + {disable first call to GetElement flag} + FirstCalltoGetElement := false; + end; + + if SortStatus <> 0 then + GetElement := False + + else if MergeFileCount = 0 then begin + {No merging required} + if RunElement >= RunCount then + {No more elements} + GetElement := False + else begin + MoveElement(ElementPtrF(RunElement), @X); + inc(RunElement); + GetElement := True; + end; + + end else begin + {Get next merge element} + NextElementIndex := GetNextElementIndex; + if NextElementIndex = 0 then + {No more elements or error} + GetElement := False + else begin + {Return the element} + MoveElement(MergePtrs[NextElementIndex], @X); + {Get pointer to next element in the stream just used} + GetMergeElementPtr(NextElementIndex); + GetElement := True; + end; + end; + end; + + function DefaultMergeName(Dest : PChar; MergeNum : Word) : PChar; + var + S : array[0..5] of Char; + begin + Str(MergeNum, S); + DefaultMergeName := StrCat(StrCat(StrCopy(Dest, 'SOR'), S), '.TMP'); + end; + + procedure AbortSort; + begin + SortStatus := 1; + end; + + function OptimumHeapToUse(RecLen : Word; NumRecs : LongInt) : LongInt; + begin + {Swap elements or pointers?} + SwapPointers := (RecLen >= SwapThreshold) and + (RecLen <= 65535-SizeOf(Pointer)); + if SwapPointers then + inc(RecLen, SizeOf(Pointer)) + else + {Account for swap element} + inc(NumRecs); + {Account for pivot element} + inc(NumRecs); + + {Compute largest power-of-two number of recs that fit into 64K} + GetMaxRecsPerSel(RecLen); + + {Compute number of selectors} + repeat + SelectorCount := NumRecs div RecsPerSel; + if NumRecs mod RecsPerSel <> 0 then + inc(SelectorCount); + if SwapPointers then + {Last selector used for run output buffer when swapping pointers} + inc(SelectorCount); + if SelectorCount < MergeOrder+1 then + RecsPerSel := RecsPerSel shr 1; + until (SelectorCount >= MergeOrder+1) or (RecsPerSel = 0); + + {!!.42 end of function modified} + + if RecsPerSel = 0 then begin + {Special case for very small number of records} + RecsPerSel := 1; + SelectorCount := MergeOrder+1; + end; + + if SwapPointers then + {Last segment reserved for merge output buffer} + inc(SelectorCount); + {Assume 32 byte overhead per selector and 2048 byte fixed overhead} + OptimumHeapToUse := 2048+ + SelectorCount*(LongInt(RecsPerSel)*RecLen+32); + end; + + function MinimumHeapToUse(RecLen : Word) : LongInt; + var + MinHeapUsed : LongInt; + HeapToUse : LongInt; + begin + {Swap elements or pointers?} + SwapPointers := (RecLen >= SwapThreshold) and + (RecLen <= 65535-SizeOf(Pointer)); + if SwapPointers then + inc(RecLen, SizeOf(Pointer)); + + {Compute largest power-of-two number of recs that fit into 64K} + GetMaxRecsPerSel(RecLen); + + {Try all valid RecsPerSel} + MinHeapUsed := MaxLongInt; + repeat + {Try minimum number of selectors} + SelectorCount := MergeOrder+1; + repeat + AllocatedRecs := LongInt(RecsPerSel)*SelectorCount; + if SwapPointers then + RunCapacity := AllocatedRecs-RecsPerSel-1 + else + RunCapacity := AllocatedRecs-2; + if RunCapacity < MinRecsPerRun then + inc(SelectorCount); + until RunCapacity >= MinRecsPerRun; + HeapToUse := 2048+SelectorCount*(LongInt(RecsPerSel)*RecLen+32); + if HeapToUse < MinHeapUsed then + MinHeapUsed := HeapToUse; + RecsPerSel := RecsPerSel shr 1; + until RecsPerSel = 0; + + MinimumHeapToUse := MinHeapUsed; + end; + + procedure MergeInfo(MaxHeapToUse : LongInt; + RecLen : Word; + NumRecs : LongInt; + var MI : MergeInfoRec); + type + MergeFileSizeArray = array[1..16383] of LongInt; + var + InitAvail : LongInt; + RecordsLeft : LongInt; + RecordsInFile : LongInt; + DiskSpace : LongInt; + OutputSpace : LongInt; + PeakDiskSpace : LongInt; + MFileCount : LongInt; + RecsNeeded : LongInt; + SizeBufSize : Word; + MergeFileSizeP : ^MergeFileSizeArray; + begin + {Set defaults for the MergeInfoRec} + FillChar(MI, SizeOf(MergeInfoRec), 0); + + {Validate input parameters} + SortStatus := ValidateInput(RecLen); + if SortStatus = 0 then + if NumRecs = 0 then + SortStatus := 213; + + {Compute selector sizes and allocate buffers} + if SortStatus = 0 then begin + InitAvail := MemAvail; + SortStatus := GetHandles(RecLen, MaxHeapToUse); + end; + + {Get out if sort is predicted to fail} + if SortStatus <> 0 then begin + MI.SortStatus := SortStatus; + Exit; + end; + + {Compute amount of memory used while getting handles} + dec(InitAvail, MemAvail); + MI.HeapUsed := InitAvail; + + {Deallocate the memory allocated by GetHandles} + FreeAllHandles; + + RecsNeeded := NumRecs+1; + if not SwapPointers then + inc(RecsNeeded); + + if DSelectorCount*LongInt(RecsPerSel) >= RecsNeeded then begin + {All the records fit into memory} + MI.SelectorCount := SelectorCount; + MI.RecsPerSel := RecsPerSel; + Exit; + end; + + {Store the information we already know} + MI.SelectorCount := SelectorCount; + MI.RecsPerSel := RecsPerSel; + + {Compute initial number of merge files and disk space} + MFileCount := NumRecs div RunCapacity; + if NumRecs mod RunCapacity <> 0 then + inc(MFileCount); + if MFileCount > 65535 then begin + MI.SortStatus := 214; + Exit; + end; + MergeFileCount := MFileCount; + DiskSpace := NumRecs*RecordLen; + + {At least one merge phase required} + MI.MergePhases := 1; + + if MergeFileCount <= MergeOrder then begin + {Only one merge phase, direct to user} + MI.MergeFiles := MergeFileCount; + MI.MergeHandles := MergeFileCount; + MI.MaxDiskSpace := DiskSpace; + Exit; + end; + + {Compute total number of merge files and merge phases} + MergeFileMerged := 0; + while MergeFileCount-MergeFileMerged > MergeOrder do begin + inc(MI.MergePhases); + MergeOpenCount := 0; + while (MergeOpenCount < MergeOrder) and (MergeFileMerged < MergeFileCount) do begin + inc(MergeOpenCount); + inc(MergeFileMerged); + end; + inc(MergeFileCount); + end; + + {Store the information we already know} + MI.MergeFiles := MergeFileCount; + MI.MergeHandles := MergeOrder+1; {MergeOrder input files, 1 output file} + + {Determine whether the disk space analysis can proceed} + SizeBufSize := MergeFileCount*SizeOf(LongInt); + if (MergeFileCount > 16383) or (MaxAvail < SizeBufSize) then begin + MI.MaxDiskSpace := -1; + Exit; + end; + + {Allocate file size array} + GetMem(MergeFileSizeP, SizeBufSize); + + {Compute size of initial merge files} + RecordsLeft := NumRecs; + MergeFileCount := 0; + while RecordsLeft > 0 do begin + inc(MergeFileCount); + if RecordsLeft >= RunCapacity then + RecordsInFile := RunCapacity + else + RecordsInFile := RecordsLeft; + MergeFileSizeP^[MergeFileCount] := RecordsInFile*RecordLen; + dec(RecordsLeft, RecordsInFile); + end; + + {Carry sizes forward to get disk space used} + PeakDiskSpace := DiskSpace; + MergeFileMerged := 0; + while MergeFileCount-MergeFileMerged > MergeOrder do begin + MergeOpenCount := 0; + OutputSpace := 0; + while (MergeOpenCount < MergeOrder) and (MergeFileMerged < MergeFileCount) do begin + inc(MergeOpenCount); + inc(MergeFileMerged); + inc(OutputSpace, MergeFileSizeP^[MergeFileMerged]); + end; + inc(MergeFileCount); + {Save size of output file} + MergeFileSizeP^[MergeFileCount] := OutputSpace; + {Output file and input files coexist temporarily} + inc(DiskSpace, OutputSpace); + {Store new peak disk space} + if DiskSpace > PeakDiskSpace then + PeakDiskSpace := DiskSpace; + {Account for deleting input files} + dec(DiskSpace, OutputSpace); + end; + MI.MaxDiskSpace := PeakDiskSpace; + + FreeMem(MergeFileSizeP, SizeBufSize); + end; + + function GetSortStatus : Word; + begin + GetSortStatus := SortStatus; + end; + +end. diff --git a/src/wc_sdk/netbios.pas b/src/wc_sdk/netbios.pas new file mode 100644 index 0000000..53f4323 --- /dev/null +++ b/src/wc_sdk/netbios.pas @@ -0,0 +1,1872 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$F-,V-,B-,S-,I-,R-} + {$IFDEF CanAllowOverlays} + {$F+,O+,A-} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-} + {$ENDIF} + + {$IFDEF DPMIorWnd} + {$C FIXED PERMANENT DEMANDLOAD} + {$ENDIF} + + {$UNDEF SmartCallbacks} + {$IFDEF Windows} + {$IFNDEF VER15} + {$IFOPT K+} + {$IFDEF Ver70} + {$DEFINE SmartCallbacks} + {$ENDIF} + {$IFDEF Ver80} + {$DEFINE SmartCallbacks} + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + + +{ + This unit implements support for NetBios name, Datagram and session + functions. These facilities can be used to implement peer to peer (station + to station) communications. + + Supports NoWait operation with Post Routines. + + This unit was completely rewritten for B-Tree Filer version 5.50 to + clean up the interface, especially between real mode and other targets, + and also to follow the naming conventions of B-Tree Filer for C. + + Note that under Windows, the VNETBIOS driver in KERNEL takes care + of calling the real mode NetBIOS driver, and so we don't need to. +} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit NetBios; + +interface + +uses + {$IFDEF Windows} + WinProcs, + WinTypes, + {$IFDEF Ver80} + DosSupp; + {$ELSE} + WinDos; + {$ENDIF} + {$ELSE} + {$IFNDEF FPC} + {$IFDEF DPMI} + WinAPI, + Dos, + DPMI; + {$ELSE} + {$ENDIF} + {$ENDIF} + Dos; + {$ENDIF} + +const + NetBiosIntr = $5C; {NetBios is accessed through int 5Ch} + NetBiosInt21FC = $2A; {or DOS function 2Ah} + MaxSessionCount = 254; {the max number of sessions allowed} + + NoWait = $80; {allows function calls to return immediately} + + NBNameMax = 16; {max number of chars in NetBIOS name string} + +{===The NetBIOS function codes===} +const + NBInvalidCommand = $7F; {an invalid NetBIOS call for testing} + + NBAddName = $30; {subfn to add a name} + NBAddGroupName = $36; {subfn to add a group name} + NBDeleteName = $31; {subfn to delete a name} + NBFindName = $78; {subfn to find a name} + + NBResetWaitOnly = $32; {subfn to reset adpater} + NBCancelWaitOnly = $35; {subfn to cancel pending NetBIOS call} + + NBCall = $10; {subfn to "call" another station} + NBListen = $11; {subfn to listen for "call" from another station} + NBHangUp = $12; {subfn to hangup a session} + NBSend = $14; {subfn to send a packet} + NBSendNoAck = $71; + NBChainSend = $17; + NBChainSendNoAck = $72; + NBReceive = $15; {subfn to receive a packet} + NBReceiveAny = $16; + + NBSendDatagram = $20; {subfn to send a datagram} + NBReceiveDatagram = $21; {subfn to receive a datagram} + NBSendBDatagram = $22; {subfn to send a broadcast datagram} + NBReceiveBDatagram = $23; {subfn to receive a datagram} + + NBAdapterStatus = $33; + +{===The NetBIOS Error Codes===} + NBESuccess = $00; {successful operation} + NBEInvalidBufferLength = $01; + NBEInvalidCommand = $03; + NBETimedOut = $05; + NBEIncomplete = $06; + NBELocalNoAckFailed = $07; + NBEInvalidLSN = $08; + NBENoResourceAvail = $09; + NBESessionClosed = $0A; + NBECommandCancelled = $0B; + NBEDuplicateName = $0D; + NBENameTableFull = $0E; + NBENameHasActive = $0F; + NBELocalSessionTableFull= $11; + NBESessionNoListen = $12; + NBEIllegalNameNumber = $13; + NBECannotFindName = $14; + NBENoAnswer = $14; + NBEInvalidName = $15; + NBENameInUseOnRemote = $16; + NBENameDeleted = $17; + NBESessionAbnormal = $18; + NBENameConflict = $19; + NBEIncompatibleDevice = $1A; + NBEInterfaceBusy = $21; + NBETooManyCommands = $22; + NBEInvalidLanA = $23; + NBECompletedWhileCancel = $24; + NBEReservedName = $25; + NBENotValidCancel = $26; + + NBESystemError = $40; + NBEHotCarrierFromRemote = $41; + NBEHotCarrier = $42; + NBENoCarrier = $43; + + {50h-F6h INDICATE ADAPTER MALFUNCTION} + + NBECommandPending = $FF; + NBEDPMIError = $FE; {general DPMI error, subclassed below} + NBEUnexpectedAdaptClose = $FD; + + {Extra error codes for DPMI problems - for NetBiosDPMIErrorCode} + NBEOutOfMemory = $01; {No DOS addressable memory available} + NBEBadPacket = $02; {Data packet is not real mode addressable} + NBEBadNCB = $03; {NCB is not real mode addressable} + +var + NetBiosDPMIErrorCode : integer; + {if a NETBIOS routine returns NBEDPMIError, then this variable + will contain NBEOutOfMemory, NBEBadPacket, or NBEBadNCB} + +{$IFDEF DPMI} +const + NetBiosReenterError : boolean = false; + {In protected mode the NetBIOS post event routines use a DPMI + callback. Generally these are not reentrant. The NETBIOS unit + traps any attempts at reentrancy and sets this flag before + immediately returning. It is up to the programmer to reset it.} +{$ENDIF} + +const + DefaultAdapterNum : Byte = 0; {the default adapter number} + +type + NBNameStr = String[NBNameMax]; {type for NetBIOS names} + CallNameType = Array [1..NBNameMax] of Char; + {used by NetBIOS internally for names} + + {Pointer to NetBIOS Control Block} + PNCB = ^TNCB; + + {The NetBIOS Post Routine procedure type definition} + NetBiosPostRoutine = procedure(LastError : Byte; N : PNCB); + + {The NetBIOS Control Block} + TNCB = record + Command : Byte; {the NetBIOS command} + RetCode : Byte; {the return code} + LSN : Byte; {the local session num} + NameNum : Byte; {the NetBIOS name table num} + Buffer : Pointer; {point to data buffer} + BufLen : Word; {length of the data buffer} + RemName : CallNameType; {the remote name} + LocName : CallNameType; {the local name} + RTO : Byte; {Receive Time Out} + STO : Byte; {Send Time Out} + PostRoutine : Pointer; {the post event routine} + LanANum : Byte; {the LAN adapter number} + CmdComplete : Byte; {the command complete flag} + Reserved : Array[1..14] of Byte; {filler to make 64 bytes in all} + {$IFDEF Windows} + PostEvProc : NetBiosPostRoutine; + {$IFDEF SmartCallbacks} + OurDS : word; + {$ENDIF} + {$ENDIF} + end; + + {The NetBIOS post routine handler definition} + PPostHandler = ^TPostHandler; + {$IFDEF DPMI} + RealModeCallbackProc = pointer; + TPostHandler = record + Regs : DPMIRegisters; + TempRegs : DPMIRegisters; + Post : NetBiosPostRoutine; + CallBack : RealModeCallbackProc; + Sele : Word; {!!.51} + OurDS : Word; + InUse : Boolean; + end; + {$ELSE} + TPostHandler = record + OurDS : Word; + Post : NetBiosPostRoutine; + {$IFDEF MSDOS} + IntrHandler : array [0..21] of Byte; + {$ENDIF} + CallBack : Pointer; + end; + {$ENDIF} + + {The NetBIOS data packet or datagram} + PnbPacket = pointer; + + {NetBIOS status information - returned by NetBiosInfo} + NetBiosName = record + Name : CallNameType; + Number : Byte; + Status : Byte; + end; + PNetBiosStatus = ^TNetBiosStatus; + TNetBiosStatus = record + PermanentNodeName : array [1..6] of char; {hardware node name} + ExtJumpers : byte; + SelfTest : byte; + ProtocolMajor : byte; {version number - major} + ProtocolMinor : byte; {..and minor} + ReportingPeriod : word; {dynamic status of driver} + CRCCount : word; + AlignmentErrors : word; + Collisions : word; + TransmitAborts : word; + Transmits : longint; + Receives : longint; + Retransmits : word; + ResourceDepletion : word; + ReservedArea1 : array [1..8] of byte; + FreeCommandBlocks : word; {available pending commands} + CurrentMaxNCBs : word; {max NCBs driver configured for} + HardwareMaxNCBs : word; {max NCBs driver can support} + ReservedArea2 : array [1..4] of byte; + Sessions : word; {current number of active sessions} + CurrentMaxSessions : word; {max sessions driver configured for} + HardwareMaxSessions: word; {max sessions driver can support} + MaxPacketSize : word; {largest packet in bytes} + NameCount : word; {number of names in adapter table} + NetBiosNames : array [1..16] of NetBiosName; + {start of variable length array} + end; + + +{===NetBIOS memory and routine allocation services===} +function NetBiosAllocNCB : PNCB; + {-Allocate memory for an NCB} + +function NetBiosAllocPacket(Size : word) : PnbPacket; + {-Allocate memory for a packet} + +function NetBiosAllocPost(Handler : NetBiosPostRoutine) : PPostHandler; + {-Allocates and returns a post-event handler} + +procedure NetBiosClearNCB(N : PNCB); + {-Initializes an NCB to zero. Required before using an NCB.} + +procedure NetBiosFreeNCB(N : PNCB); + {-Frees an NCB allocated with NetBiosAllocNCB} + +procedure NetBiosFreePacket(P : PnbPacket); + {-Frees a packet P allocated with NetBiosAllocPacket} + +procedure NetBiosFreePost(P : PPostHandler); + {-Frees a post-event handler allocated with NetBiosAllocPost} + + +{===NetBIOS name services===} +function NetBiosAddGroupName(NameToAdd : NBNameStr; + var NameNumber : Byte) : Byte; + {-Adds a group name to the local NetBIOS name table} + +function NetBiosAddName(NameToAdd : NBNameStr; + var NameNumber : Byte) : Byte; + {-Adds a name to the local NetBIOS name table} + +function NetBiosDeleteName(NameToDelete : NBNameStr) : Byte; + {-Deletes a name or group name from the local NetBIOS name table} + + +{===NetBIOS session initialisation and closedown===} +function NetBiosHangUp(SessionNumber : Byte) : Byte; + {-Closes an existing session} + +function NetBiosListen(RemoteName, LocalName : NBNameStr; + SendTimeOut, RecTimeOut : Byte; + var SessionNumber : Byte) : Byte; +procedure NetBiosListenNoWait(N : PNCB; + PostEvent : PPostHandler; + RemoteName, LocalName : NBNameStr; + SendTimeOut, RecTimeOut : Byte); + {-Listens for a "calls" from another station to initiate a session, the + first routine waits for the connection and the second does not.} + +function NetBiosOpen(RemoteName, LocalName : NBNameStr; + SendTimeOut, RecTimeOut : Byte; + var SessionNumber : Byte) : Byte; +procedure NetBiosOpenNoWait(N : PNCB; + PostEvent : PPostHandler; + RemoteName, LocalName : NBNameStr; + SendTimeOut, RecTimeOut : Byte); + {-"Calls" another station to initiate a session, the first routine waits + for the connection and the second does not.} + + +{===NetBIOS session send/receive services===} +function NetBiosCancelRequest(N : PNCB) : Byte; + {-Cancels a pending NetBIOS request} + +function NetBiosReceive(SessionNumber : Byte; + PacketSize : Word; + Packet : PnbPacket) : Byte; +procedure NetBiosReceiveNoWait(N : PNCB; + PostEvent : PPostHandler; + SessionNumber : Byte; + PacketSize : Word; + Packet : PnbPacket); + {-Receives a packet via NetBIOS session, the first routine waits until + event complete, the second does not} + +function NetBiosSend(SessionNumber : Byte; + PacketSize : Word; + Packet : PnbPacket) : Byte; +procedure NetBiosSendNoWait(N : PNCB; + PostEvent : PPostHandler; + SessionNumber : Byte; + PacketSize : Word; + Packet : PnbPacket); + {-Sends a packet via NetBIOS session, the first routine waits until the + event is complete, the second does not} + + +{===NetBIOS datagram services===} +function NetBiosReceiveBDG(ReceiverNameNum : Byte; + DatagramSize : Word; + Datagram : PnbPacket) : Byte; +procedure NetBiosReceiveBDGNoWait(N : PNCB; + PostEvent : PPostHandler; + ReceiverNameNum : Byte; + DatagramSize : Word; + Datagram : PnbPacket); + {-Receive a broadcast datagram, with or without a wait for the event + to complete} + +function NetBiosReceiveDG(ReceiverNameNum : Byte; + DatagramSize : Word; + Datagram : PnbPacket) : Byte; +procedure NetBiosReceiveDGNoWait(N : PNCB; + PostEvent : PPostHandler; + ReceiverNameNum : Byte; + DatagramSize : Word; + Datagram : PnbPacket); + {-Receive a datagram, with or without a wait for the event to complete} + +function NetBiosSendBDG(SenderNameNum : Byte; + DatagramSize : Word; + Datagram : PnbPacket) : Byte; +procedure NetBiosSendBDGNoWait(N : PNCB; + PostEvent : PPostHandler; + SenderNameNum : Byte; + DatagramSize : Word; + Datagram : PnbPacket); + {-Send a broadcast datagram, with or without a wait for the event to + complete} + +function NetBiosSendDG(SenderNameNum : Byte; + ReceiverName : NBNameStr; + DatagramSize : Word; + Datagram : PnbPacket) : Byte; +procedure NetBiosSendDGNoWait(N : PNCB; + PostEvent : PPostHandler; + SenderNameNum : Byte; + ReceiverName : NBNameStr; + DatagramSize : Word; + Datagram : PnbPacket); + {-Send a datagram, with or without a wait for the event to complete} + + +{===NetBIOS miscellaneous===} +function NetBiosCmdCompleted(N : PNCB; var FinalRetCode : Byte) : Boolean; + {-Returns True if NetBIOS call made in NoWait state has been completed. + If the event is complete, the final return code for the call is + returned.} + +function NetBiosInfo(NS : PNetBiosStatus; + Name : NBNameStr; + MaxNames : byte) : byte; + {-Returns information about a NetBIOS driver or adapter} + +function NetBiosInstalled : Boolean; + {-Returns TRUE if NetBIOS is installed} + +procedure NetBiosRequest(N : PNCB); + {-Calls the NetBIOS driver with the given NCB} + {$IFNDEF DPMI} + inline($5B/ {pop bx} + $07/ {pop es} + $1E/ {push ds} + $CD/NetBiosIntr/ {int $5C} + $1F); {pop ds} + {$ENDIF} + +function NetBiosResetAdapter(SessionCount : Byte; + CommandCount : Byte) : Byte; + {-Reset the NETBIOS adapter given by DefaultAdapterNum.} + + +implementation + +type + LH = record L, H : word; end; {split a longint into lo/hi words} + OS = record O, S : word; end; {split a pointer into Sel/Seg and Ofs} + +{Note: to isolate the different usage of packets in protected mode +programming and in real mode programming (basically we *must* have a +DOS memory block in protected mode, and it's the real mode pointer +to the block that is passed to NetBIOS), NetBiosAllocPacket will +return the address of a block of memory that follows directly on from +an 8 byte block of the form TPacketInfo. By this 'trick' we can ensure +packets (or datagrams) passed to the relevant NetBios routines in +protected mode have been properly allocated, and also the code for +calling these routines is the same in real mode and protected mode. +Windows programmers are spoilt because the KERNEL DLL will provide the +pmode to real mode mappings for us, so they can just 'pretend' to be +real mode programmers.} +type + PPacketInfo = ^TPacketInfo; + TPacketInfo = record {THIS MUST BE EIGHT (8) BYTES} + Sig : word; {Always 'PI' back-words} + RealPtr : pointer; {DPMI real-mode pointer to data} + DSize : word; {size of data block} + end; +const + PacketSig = $4950; {'PI' back-words} + +{---utility routines---} +function nbHeapError(Size : word) : integer; far; + {-Simple heap error function for nbGetMem} + begin + nbHeapError := 1; + end; + +function nbGetMem(var P; Size : word) : boolean; near; + {-Safe memory allocation, return true is successful} + var + Pt : pointer absolute P; + SaveHeapError : pointer; + begin + SaveHeapError := HeapError; + HeapError := @nbHeapError; + GetMem(Pt, Size); + nbGetMem := Pt <> nil; + HeapError := SaveHeapError; + end; + +{$IFDEF DPMI} +function DOSGetMem(var RealPtr, ProtPtr; Size : word) : boolean; near; + var + RealMode : pointer absolute RealPtr; + ProtMode : pointer absolute ProtPtr; + AllocResult : longint; + begin + AllocResult := GlobalDOSAlloc(Size); + if (AllocResult <> 0) then + begin + RealMode := Ptr(LH(AllocResult).H, 0); + ProtMode := Ptr(LH(AllocResult).L, 0); + DOSGetMem := true; + end + else DOSGetMem := false; + end; + +function DOSFreeMem(ProtPtr : pointer) : boolean; near; + begin + DOSFreeMem := GlobalDOSFree(OS(ProtPtr).S) = 0; + end; +{$ENDIF} + +{$IFDEF DPMI} +procedure NetBiosCallBackShell; far; assembler; + { ES:DI points to the DPMI register structure } + { (this will be the one at the top of TPostHandler)} + { DS:SI points to the real mode's SS:SP } + const + SizeOfDPMIRegs = sizeof(DPMIRegisters); + asm + {Entering a critical section} + mov ax, 1681h + int 2Fh + {Are we reentering?} + cmp es:[di].TPostHandler.InUse, 1 + je @@TryingToReenter + {Make sure we can't be reentered} + mov es:[di].TPostHandler.InUse, 1 + {Fix the DPMI registers for our return} + cld + lodsw; mov es:[di].TPostHandler.Regs.&IP, ax + lodsw; mov es:[di].TPostHandler.Regs.&CS, ax + lodsw; mov es:[di].TPostHandler.Regs.&Flags, ax + add es:[di].TPostHandler.Regs.&SP, 6 + {Copy the DPMI registers Regs to TempRegs} + mov bx, di + mov si, di + mov cx, SizeOfDPMIRegs + add di, cx + mov ax, es; mov ds, ax + push es; push di; push bx + shr cx, 1 + rep movsw + {Leaving critical section, turn on interrupts} + mov ax, 1682h + int 2Fh + mov ax, 0901h + int 31h + {Set up our DS} {!!.51 start} + mov ds, es:[bx].TPostHandler.OurDS + {Remap our selector onto the NCB} + push bx + mov dx, es:[bx].TPostHandler.TempRegs.&ES + xor ax, ax + mov al, dh + mov cl, 4 + shr ax, cl + shl dx, cl + xchg ax, cx + mov bx, es:[bx].TPostHandler.Sele + mov ax, $7 + int $31 + xchg ax, bx + pop bx + {Push the parameters for the post routine and call it} + push word ptr es:[bx].TPostHandler.TempRegs.&AX + push ax + push word ptr es:[bx].TPostHandler.TempRegs.&BX {!!.51 end} + call dword ptr es:[bx].TPostHandler.Post + {Get the TPostHandler back, turn off interrupts, reset InUse flag} + pop bx; pop di; pop es + mov ax, 0900h + int 31h + mov es:[bx].TPostHandler.InUse, 0 + iret + + @@TryingToReenter: + {The callback is already active, so get out NOW} + cld + lodsw; mov es:[di].TPostHandler.Regs.&IP, ax + lodsw; mov es:[di].TPostHandler.Regs.&CS, ax + lodsw; mov es:[di].TPostHandler.Regs.&Flags, ax + add es:[di].TPostHandler.Regs.&SP, 6 + mov ds, es:[di].TPostHandler.OurDS + mov NetBiosReenterError, 1 + mov ax,1682h + int 2Fh + iret + end; +{$ENDIF} + +{$IFDEF MSDOS} +const + {This interrupt routine gets copied into every post-event routine's + control block by NetBiosAllocPost. It provides a callback to allow + a normal Pascal routine to be called by NetBIOS.} + NetBiosIntrCode : array [0..21] of byte + = ($E8, $00, $00, { call @@1 } {Get this code's offset} + $5F, {@@1: pop di } {..into DI} + $50, $06, $53, { push ax, es, bx } {push handler's parameters} + $83, $EF, $09, { sub di, 9 } {point to struc's DataSeg} + $2E, $8E, $1D, { mov ds, cs:[di] } {set up DS} + $83, $C7, $02, { add di, 2 } {point to handler} + $2E, $FF, $1D, { call far cs:[di] } {call handler} + $CF, { iret } {return to NetBIOS} + $90, $90); {..filler nop bytes } +{$ENDIF} + +{$IFDEF Windows} +var + WindowsPostEventHandler : pointer; + +procedure WinPost; export; assembler; + asm + {Note: smart callbacks don't work with the VNETBIOS driver that's in + KERNEL (I'm not sure why) because the callback gets called with + an SS value that's not the application's SS. As SS gets copied + into DS for our data segment, we need to patch our own DS value.} + {$IFDEF SmartCallbacks} + mov ax, es:[bx].TNCB.OurDS + mov ds, ax + {$ENDIF} + {Note: the instance thunk will trash AX. As this is where NetBIOS + puts the return code, we must get it again from the value + in the NCB for the user's postevent handler.} + xor ax, ax + mov al, es:[bx].TNCB.RetCode + push ax + push es + push bx + call es:[bx].TNCB.PostEvProc + {Note: the VNETBIOS driver allows us to do a far return rather than + the more usual IRET. Handy: we don't have to duplicate the + normal routine exit code.} + end; +{$ENDIF} + +function GetPtrForDriver(Packet : PnbPacket) : pointer; + {-Returns a pointer for Packet that the NetBIOS driver can use.} + {$IFDEF DPMI} + assembler; + asm + les bx, Packet + sub bx, 6 + mov ax, es:[bx] + mov dx, es:[bx+2] + end; + {$ELSE} + inline($58/$5A); {pop ax; pop dx} + {$ENDIF} + +function IsAnotherPacketType(Packet : PnbPacket) : boolean; + {-Returns true if Packet was *not* allocated by NetBiosAllocPacket} + {$IFDEF DPMI} + assembler; + asm + mov ax, 1 {assume true, ie it's not ours} + mov bx, Packet.Word[0] {get offset} + sub bx, 8 {subtract sizeof(TPacketInfo)} + jl @@Exit {if negative not ours, so exit} + mov es, Packet.Word[2] {get segment/selector} + cmp word ptr es:[bx], PacketSig {1st word should be signature} + jne @@Exit {no, so not ours} + xor ax, ax {it's our type, return false} + @@Exit: + end; + {$ELSE} + begin + IsAnotherPacketType := true; + if (OS(Packet).O >= sizeof(TPacketInfo)) then + begin + dec(OS(Packet).O, sizeof(TPacketInfo)); + if (PPacketInfo(Packet)^.Sig = PacketSig) then + IsAnotherPacketType := false; + end; + end; + {$ENDIF} + +function NetBiosAllocPacket(Size : word) : PnbPacket; + var + P : PPacketInfo; + R : pointer; + begin + {$IFDEF DPMI} + if DOSGetMem(R, P, Size+sizeof(TPacketInfo)) then + begin + with P^ do + begin + Sig := PacketSig; + RealPtr := R; + inc(OS(RealPtr).O, sizeof(TPacketInfo)); + DSize := Size; + end; + inc(OS(P).O, sizeof(TPacketInfo)); + end + else P := nil; + {$ELSE} + if nbGetMem(P, Size+sizeof(TPacketInfo)) then + begin + with P^ do + begin + Sig := PacketSig; + RealPtr := P; + inc(OS(RealPtr).O, sizeof(TPacketInfo)); + DSize := Size; + end; + P := P^.RealPtr; + end; + {$ENDIF} + NetBiosAllocPacket := PnbPacket(P); + end; + +procedure NetBiosFreePacket(P : PnbPacket); + var + Size : word; + TempP : PPacketInfo; + begin + if not IsAnotherPacketType(P) then + begin + TempP := P; + dec(OS(TempP).O, sizeof(TPacketInfo)); + Size := TempP^.DSize+sizeof(TPacketInfo); + {trash the memory block to ensure that it cannot inadvertently + be used again without reallocation} + FillChar(TempP^, Size, $CC); + {$IFDEF DPMI} + if not DOSFreeMem(TempP) then + {nothing}; + {$ELSE} + FreeMem(TempP, Size); + {$ENDIF} + end; + end; + +procedure NetBiosClearNCB(N : PNCB); + begin + if (N <> nil) then + begin + FillChar(N^, SizeOf(TNCB), 0); {fill the NCB with 0} + N^.LanANum := DefaultAdapterNum; + end; + end; + +function NetBiosAllocNCB : PNCB; + begin + NetBiosAllocNCB := PNCB(NetBiosAllocPacket(sizeof(TNCB))); + end; + +procedure NetBiosFreeNCB(N : PNCB); + begin + NetBiosFreePacket(PnbPacket(N)); + end; + +function NetBiosAllocPost(Handler : NetBiosPostRoutine) : PPostHandler; + var + P : PPostHandler; + Dummy : word; + begin + if nbGetMem(P, sizeof(TPostHandler)) then + with P^ do + begin + Post := Handler; + OurDS := DSeg; + {$IFDEF DPMI} + InUse := false; + FillChar(Regs, sizeof(Regs), 0); + if (AllocRealModeCallBackAddr(@NetBiosCallBackShell, Regs, Callback) <> 0) then + begin + {no callbacks left - dispose of the memory block} + Dispose(P); + P := nil; + end; + if (AllocLDTDescriptors(1, Sele) <> 0) then {!!.51 start} + begin + {out of selectors-yuk} + Dummy := FreeRealModeCallbackAddr(Callback); + Dispose(P); + P := nil; + end + else + begin + if (SetSegmentLimit(Sele, sizeof(TNCB) + sizeof(TPacketInfo)) <> 0) then + begin + {Error resizing the selector-unusual} + Dummy := FreeLDTDescriptor(Sele); + Dummy := FreeRealModeCallbackAddr(Callback); + Dispose(P); + P := nil; + end; + end; {!!.51 end} + {$ELSE} + {$IFDEF MSDOS} + Move(NetBiosIntrCode, IntrHandler, sizeof(IntrHandler)); + CallBack := @IntrHandler; + {$ELSE} {ie Windows} + CallBack := WindowsPostEventHandler; + {$ENDIF} + {$ENDIF} + end; + NetBiosAllocPost := P; + end; + +procedure NetBiosFreePost(P : PPostHandler); + var + Dummy : word; + begin + if (P <> nil) then + begin + {$IFDEF DPMI} + Dummy := FreeRealModeCallbackAddr(P^.Callback); + Dummy := FreeLDTDescriptor(P^.Sele); {!!.51} + {$ENDIF} + Dispose(P); + end; + end; + +function NetBiosCancelRequest(N : PNCB) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + if IsAnotherPacketType(PnbPacket(N)) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + NetBiosCancelRequest := NBEDPMIError; + Exit; + end; + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosCancelRequest := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {Build the NCB for the cancel request. Note the buffer is pointed + at the NCB to cancel} + with TempNCB^ do + begin + Command := NBCancelWaitOnly; {this function always waits} + Buffer := GetPtrForDriver(N); + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {the return value is the NetBIOS RetCode} + with TempNCB^ do + NetBiosCancelRequest := RetCode; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +function NetBiosAddName(NameToAdd : NBNameStr; + var NameNumber : Byte) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosAddName := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBAddName; + {set the name: note that it will automatically be padded with + nulls because of the NetBiosClearNCB.} + Move(NameToAdd[1], LocName, Length(NameToAdd)); + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code, and number of name in table} + with TempNCB^ do + begin + NetBiosAddName := RetCode; + NameNumber := NameNum; + end; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +function NetBiosAddGroupName(NameToAdd : NBNameStr; + var NameNumber : Byte) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosAddGroupName := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBAddGroupName; + {set the name: note that it will automatically be padded with + nulls because of the NetBiosClearNCB.} + Move(NameToAdd[1], LocName, Length(NameToAdd)); + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code, and number of name in table} + with TempNCB^ do + begin + NetBiosAddGroupName := RetCode; + NameNumber := NameNum; + end; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +function NetBiosDeleteName(NameToDelete : NBNameStr) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosDeleteName := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBDeleteName; + {set the name: note that it will automatically be padded with + nulls because of the NetBiosClearNCB.} + Move(NameToDelete[1], LocName, Length(NameToDelete)); + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code} + with TempNCB^ do + NetBiosDeleteName := RetCode; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +function NetBiosResetAdapter(SessionCount : Byte; + CommandCount : Byte) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosResetAdapter := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBResetWaitOnly; + LSN := SessionCount; {the max sessions} + NameNum := CommandCount; {the max pending commands} + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code} + with TempNCB^ do + NetBiosResetAdapter := RetCode; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +procedure ReportBadNCB(N : PNCB); + begin + NetBiosDPMIErrorCode := NBEBadNCB; + if (N <> nil) then + begin + NetBiosClearNCB(N); + N^.RetCode := NBEDPMIError; + end; + end; + +function GetPostRoutine(P : PPostHandler; N : PNCB) : pointer; + begin + if (P = nil) then + GetPostRoutine := nil + else + begin + GetPostRoutine := P^.CallBack; + {$IFDEF Windows} + N^.PostEvProc := P^.Post; + {$IFDEF SmartCallbacks} + N^.OurDS := P^.OurDS; + {$ENDIF} + {$ENDIF} + end; + end; + +function NetBiosOpen(RemoteName, LocalName : NBNameStr; + SendTimeOut, RecTimeOut : Byte; + var SessionNumber : Byte) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosOpen := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBCall; + Move(LocalName[1], LocName, Length(LocalName)); + Move(RemoteName[1], RemName, Length(RemoteName)); + RTO := RecTimeOut; + STO := SendTimeOut; + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code} + with TempNCB^ do + begin + NetBiosOpen := RetCode; + SessionNumber := LSN; + end; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +procedure NetBiosOpenNoWait(N : PNCB; + PostEvent : PPostHandler; + RemoteName, LocalName : NBNameStr; + SendTimeOut, RecTimeOut : Byte); + begin + {$IFDEF DPMI} + if IsAnotherPacketType(N) then + begin + ReportBadNCB(N); + Exit; + end; + {$ENDIF} + NetBiosClearNCB(N); + {build the NCB} + with N^ do + begin + Command := NBCall + NoWait; + Move(LocalName[1], LocName, Length(LocalName)); + Move(RemoteName[1], RemName, Length(RemoteName)); + RTO := RecTimeOut; + STO := SendTimeOut; + PostRoutine := GetPostRoutine(PostEvent, N); + end; + {call the NetBIOS} + NetBiosRequest(N); + end; + + +function NetBiosListen(RemoteName, LocalName : NBNameStr; + SendTimeOut, RecTimeOut : Byte; + var SessionNumber : Byte) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosListen := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBListen; + Move(LocalName[1], LocName, Length(LocalName)); + Move(RemoteName[1], RemName, Length(RemoteName)); + RTO := RecTimeOut; + STO := SendTimeOut; + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code} + with TempNCB^ do + begin + NetBiosListen := RetCode; + SessionNumber := LSN; + end; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +procedure NetBiosListenNoWait(N : PNCB; + PostEvent : PPostHandler; + RemoteName, LocalName : NBNameStr; + SendTimeOut, RecTimeOut : Byte); + begin + {$IFDEF DPMI} + if IsAnotherPacketType(N) then + begin + ReportBadNCB(N); + Exit; + end; + {$ENDIF} + NetBiosClearNCB(N); + {build the NCB} + with N^ do + begin + Command := NBListen + NoWait; + Move(LocalName[1], LocName, Length(LocalName)); + Move(RemoteName[1], RemName, Length(RemoteName)); + RTO := RecTimeOut; + STO := SendTimeOut; + PostRoutine := GetPostRoutine(PostEvent, N); + end; + {call the NetBIOS} + NetBiosRequest(N); + end; + +function NetBiosHangUp(SessionNumber : Byte) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosHangUp := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBHangUp; + LSN := SessionNumber; {The local session number is all that's needed} + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code} + with TempNCB^ do + NetBiosHangUp := RetCode; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +function NetBiosReceive(SessionNumber : Byte; + PacketSize : Word; + Packet : PnbPacket) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + if IsAnotherPacketType(Packet) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + NetBiosReceive := NBEDPMIError; + Exit; + end; + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosReceive := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBReceive; + LSN := SessionNumber; + Buffer := GetPtrForDriver(Packet); + BufLen := PacketSize; + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code} + with TempNCB^ do + NetBiosReceive := RetCode; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +procedure NetBiosReceiveNoWait(N : PNCB; + PostEvent : PPostHandler; + SessionNumber : Byte; + PacketSize : Word; + Packet : PnbPacket); + begin + {$IFDEF DPMI} + if IsAnotherPacketType(N) then + begin + ReportBadNCB(N); + Exit; + end; + {$ENDIF} + NetBiosClearNCB(N); + {$IFDEF DPMI} + if IsAnotherPacketType(Packet) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + N^.RetCode := NBEDPMIError; + Exit; + end; + {$ENDIF} + {build the NCB} + with N^ do + begin + Command := NBReceive + NoWait; + LSN := SessionNumber; + Buffer := GetPtrForDriver(Packet); + BufLen := PacketSize; + PostRoutine := GetPostRoutine(PostEvent, N); + end; + {call the NetBIOS} + NetBiosRequest(N); + end; + +function NetBiosSend(SessionNumber : Byte; + PacketSize : Word; + Packet : PnbPacket) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + if IsAnotherPacketType(Packet) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + NetBiosSend := NBEDPMIError; + Exit; + end; + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosSend := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBSend; + LSN := SessionNumber; + Buffer := GetPtrForDriver(Packet); + BufLen := PacketSize; + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code} + with TempNCB^ do + NetBiosSend := RetCode; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +procedure NetBiosSendNoWait(N : PNCB; + PostEvent : PPostHandler; + SessionNumber : Byte; + PacketSize : Word; + Packet : PnbPacket); + begin + {$IFDEF DPMI} + if IsAnotherPacketType(N) then + begin + ReportBadNCB(N); + Exit; + end; + {$ENDIF} + NetBiosClearNCB(N); + {$IFDEF DPMI} + if IsAnotherPacketType(Packet) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + N^.RetCode := NBEDPMIError; + Exit; + end; + {$ENDIF} + {build the NCB} + with N^ do + begin + Command := NBSend + NoWait; + LSN := SessionNumber; + Buffer := GetPtrForDriver(Packet); + BufLen := PacketSize; + PostRoutine := GetPostRoutine(PostEvent, N); + end; + {call the NetBIOS} + NetBiosRequest(N); + end; + +function NetBiosCmdCompleted(N : PNCB; var FinalRetCode : Byte) : Boolean; + begin + with N^ do + if (CmdComplete = $FF) then + NetBiosCmdCompleted := False + else + begin + FinalRetCode := RetCode; + NetBiosCmdCompleted := True; + end; + end; + +function NetBiosSendDG(SenderNameNum : Byte; + ReceiverName : NBNameStr; + DatagramSize : Word; + Datagram : PnbPacket) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + if IsAnotherPacketType(Datagram) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + NetBiosSendDG := NBEDPMIError; + Exit; + end; + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosSendDG := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBSendDatagram; + Buffer := GetPtrForDriver(Datagram); + BufLen := DatagramSize; + NameNum := SenderNameNum; + Move(ReceiverName[1], RemName, Length(ReceiverName)); + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code} + with TempNCB^ do + NetBiosSendDG := RetCode; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +procedure NetBiosSendDGNoWait(N : PNCB; + PostEvent : PPostHandler; + SenderNameNum : Byte; + ReceiverName : NBNameStr; + DatagramSize : Word; + Datagram : PnbPacket); + begin + {$IFDEF DPMI} + if IsAnotherPacketType(N) then + begin + ReportBadNCB(N); + Exit; + end; + {$ENDIF} + NetBiosClearNCB(N); + {$IFDEF DPMI} + if IsAnotherPacketType(Datagram) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + N^.RetCode := NBEDPMIError; + Exit; + end; + {$ENDIF} + {build the NCB} + with N^ do + begin + Command := NBSendDatagram + NoWait; + Buffer := GetPtrForDriver(Datagram); + BufLen := DatagramSize; + NameNum := SenderNameNum; + Move(ReceiverName[1], RemName, Length(ReceiverName)); + PostRoutine := GetPostRoutine(PostEvent, N); + end; + {call the NetBIOS} + NetBiosRequest(N); + end; + +function NetBiosSendBDG(SenderNameNum : Byte; + DatagramSize : Word; + Datagram : PnbPacket) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + if IsAnotherPacketType(Datagram) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + NetBiosSendBDG := NBEDPMIError; + Exit; + end; + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosSendBDG := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBSendBDatagram; + Buffer := GetPtrForDriver(Datagram); + BufLen := DatagramSize; + NameNum := SenderNameNum; + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code} + with TempNCB^ do + NetBiosSendBDG := RetCode; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +procedure NetBiosSendBDGNoWait(N : PNCB; + PostEvent : PPostHandler; + SenderNameNum : Byte; + DatagramSize : Word; + Datagram : PnbPacket); + begin + {$IFDEF DPMI} + if IsAnotherPacketType(N) then + begin + ReportBadNCB(N); + Exit; + end; + {$ENDIF} + NetBiosClearNCB(N); + {$IFDEF DPMI} + if IsAnotherPacketType(Datagram) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + N^.RetCode := NBEDPMIError; + Exit; + end; + {$ENDIF} + {build the NCB} + with N^ do + begin + Command := NBSendBDatagram + NoWait; + Buffer := GetPtrForDriver(Datagram); + BufLen := DatagramSize; + NameNum := SenderNameNum; + PostRoutine := GetPostRoutine(PostEvent, N); + end; + {call the NetBIOS} + NetBiosRequest(N); + end; + +function NetBiosReceiveDG(ReceiverNameNum : Byte; + DatagramSize : Word; + Datagram : PnbPacket) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + if IsAnotherPacketType(Datagram) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + NetBiosReceiveDG := NBEDPMIError; + Exit; + end; + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosReceiveDG := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBReceiveDatagram; + Buffer := GetPtrForDriver(Datagram); + BufLen := DatagramSize; + NameNum := ReceiverNameNum; + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code} + with TempNCB^ do + NetBiosReceiveDG := RetCode; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +procedure NetBiosReceiveDGNoWait(N : PNCB; + PostEvent : PPostHandler; + ReceiverNameNum : Byte; + DatagramSize : Word; + Datagram : PnbPacket); + begin + {$IFDEF DPMI} + if IsAnotherPacketType(N) then + begin + ReportBadNCB(N); + Exit; + end; + {$ENDIF} + NetBiosClearNCB(N); + {$IFDEF DPMI} + if IsAnotherPacketType(Datagram) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + N^.RetCode := NBEDPMIError; + Exit; + end; + {$ENDIF} + {build the NCB} + with N^ do + begin + Command := NBReceiveDatagram + NoWait; + Buffer := GetPtrForDriver(Datagram); + BufLen := DatagramSize; + NameNum := ReceiverNameNum; + PostRoutine := GetPostRoutine(PostEvent, N); + end; + {call the NetBIOS} + NetBiosRequest(N); + end; + +function NetBiosReceiveBDG(ReceiverNameNum : Byte; + DatagramSize : Word; + Datagram : PnbPacket) : Byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + if IsAnotherPacketType(Datagram) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + NetBiosReceiveBDG := NBEDPMIError; + Exit; + end; + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosReceiveBDG := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBReceiveBDatagram; + Buffer := GetPtrForDriver(Datagram); + BufLen := DatagramSize; + NameNum := ReceiverNameNum; + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code} + with TempNCB^ do + NetBiosReceiveBDG := RetCode; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +procedure NetBiosReceiveBDGNoWait(N : PNCB; + PostEvent : PPostHandler; + ReceiverNameNum : Byte; + DatagramSize : Word; + Datagram : PnbPacket); + begin + {$IFDEF DPMI} + if IsAnotherPacketType(N) then + begin + ReportBadNCB(N); + Exit; + end; + {$ENDIF} + NetBiosClearNCB(N); + {$IFDEF DPMI} + if IsAnotherPacketType(Datagram) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + N^.RetCode := NBEDPMIError; + Exit; + end; + {$ENDIF} + {build the NCB} + with N^ do + begin + Command := NBReceiveBDatagram + NoWait; + Buffer := GetPtrForDriver(Datagram); + BufLen := DatagramSize; + NameNum := ReceiverNameNum; + PostRoutine := GetPostRoutine(PostEvent, N); + end; + {call the NetBIOS} + NetBiosRequest(N); + end; + +function NetBIOSIntVecInstalled : Boolean; + {-Determine whether the NetBIOS interrupt vector is installed} + var + Vec : Pointer; + S : Word; + begin + {get the NetBIOS interrupt vector, isolate the segment} + {$IFDEF DPMI} + GetRealModeIntVector(NetBiosIntr, Vec); + {$ELSE} + GetIntVec(NetBiosIntr, Vec); + {$ENDIF} + S := OS(Vec).S; + {the vector is 'installed' if it's non-nil and its segment does not + point into the BIOS (ie segment $F000)} + NetBiosIntVecInstalled := (Vec <> nil) and (S <> $F000); + end; + +function BogusCallWasDetected : Boolean; + {-Issues an invalid NetBIOS call. If such a call is made, and the + adapter/driver returns the NetBIOS invalid command error code, + then NetBIOS or a NetBIOS emulator is installed.} + var + TempNCB : PNCB; + NCBBuffer : TNCB; + OrigAdapterNumber : byte; {!!.53} + begin + {$IFDEF DPMI} + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + {if we cannot allocate any DOS memory, it's moot whether the + NetBIOS is there or not: we won't be able to use it anyway} + BogusCallWasDetected := false; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBInvalidCommand; + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {if we got an "invalid adapter number" error, try and find} {!!.53} + {the valid one for this machine} {!!.53} + if (TempNCB^.RetCode = NBEInvalidLanA) then {!!.53} + begin {!!.53} + OrigAdapterNumber := DefaultAdapterNum; {!!.53} + DefaultAdapterNum := 0; {!!.53} + while (DefaultAdapterNum < 255) and {!!.53} + (TempNCB^.RetCode = NBEInvalidLanA) do {!!.53} + begin {!!.53} + NetBiosClearNCB(TempNCB); {!!.53} + TempNCB^.Command := NBInvalidCommand; {!!.53} + NetBiosRequest(TempNCB); {!!.53} + inc(DefaultAdapterNum); {!!.53} + end; {!!.53} + if (TempNCB^.RetCode = NBEInvalidCommand) then {!!.53} + dec(DefaultAdapterNum) {!!.53} + else {!!.53} + DefaultAdapterNum := OrigAdapterNumber; {!!.53} + end; {!!.53} + {check result code} + with TempNCB^ do + BogusCallWasDetected := RetCode = NBEInvalidCommand; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +function NetBiosInstalled : Boolean; + begin + NetBiosDPMIErrorCode := NBESuccess; + {a NetBIOS adapter or driver is there if (1) its vector is present + and (2) NetBIOS recognises an invalid function request} + if NetBIOSIntVecInstalled then + NetBIOSInstalled := BogusCallWasDetected + else {no valid vector} + NetBIOSInstalled := false; + end; + +{$IFDEF DPMI} +procedure NetBiosRequest(N : PNCB); + var + Dummy : word; + RealP: pointer; + Regs : DPMIRegisters; + begin + RealP := GetPtrForDriver(N); + FillChar(Regs, SizeOf(Regs), 0); + with Regs do + begin + ES := OS(RealP).S; + BX := OS(RealP).O; + end; + Dummy := SimulateRealModeInt(NetBiosIntr, Regs); + end; +{$ENDIF} + +function NetBiosInfo(NS : PNetBiosStatus; + Name : NBNameStr; + MaxNames : byte) : byte; + var + TempNCB : PNCB; + NCBBuffer : TNCB; + begin + {$IFDEF DPMI} + if IsAnotherPacketType(NS) then + begin + NetBiosDPMIErrorCode := NBEBadPacket; + NetBiosInfo := NBEDPMIError; + Exit; + end; + TempNCB := NetBiosAllocNCB; + if (TempNCB = nil) then + begin + NetBiosDPMIErrorCode := NBEOutOfMemory; + NetBiosInfo := NBEDPMIError; + Exit; + end; + {$ELSE} + TempNCB := @NCBBuffer; + {$ENDIF} + NetBiosClearNCB(TempNCB); + {build the NCB} + with TempNCB^ do + begin + Command := NBAdapterStatus; + Move(Name[1], RemName, Length(Name)); + Buffer := GetPtrForDriver(NS); + {set the buffer length: note NetBiosStatus includes space for + 16 NetBiosNames already} + BufLen := sizeof(TNetBiosStatus) + + ((word(MaxNames) - 16) * sizeof(NetBiosName)); + end; + {call the NetBIOS} + NetBiosRequest(TempNCB); + {return result code, and number of name in table} + with TempNCB^ do + begin + NetBiosInfo := RetCode; + end; + {$IFDEF DPMI} + NetBiosFreeNCB(TempNCB); + {$ENDIF} + end; + +{$IFDEF Windows} +begin + {$IFNDEF SmartCallbacks} + WindowsPostEventHandler := MakeProcInstance(@WinPost, HInstance); + {$ELSE} + WindowsPostEventHandler := @WinPost; + {$ENDIF} +{$ELSE} +{$IFDEF InitAllUnits} +begin +{$ENDIF} +{$ENDIF} +end. diff --git a/src/wc_sdk/netexamp.pas b/src/wc_sdk/netexamp.pas new file mode 100644 index 0000000..40f2625 --- /dev/null +++ b/src/wc_sdk/netexamp.pas @@ -0,0 +1,528 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +program NetExample; + {-Example calls for basic database operations on a network} + +uses + Filer; + +type + PersonDef = + record + Del : LongInt; + FirstName : String[20]; + LastName : String[25]; + Street : String[30]; + City : String[30]; + State : String[2]; + ZipCode : String[9]; + Telephone : String[15]; + Age : Integer; + end; + +var + PF : IsamFileBlockPtr; {Symbolic access to the database} + + MaxError : Integer; {Lock status variables} + RecordLocked : Boolean; + FileBlockLocked : Boolean; + +const + Key1Len = 30; {First and last name} + Key2Len = 5; {ZipCode} + Key3Len = 15; {Telephone} + + SevereError = 20; {User-defined error classes} + KeyError = 15; + DeletedError = 12; + ModifiedError = 10; + + APerson : PersonDef = + (Del : 0; + FirstName : 'George'; + LastName : 'Bush'; + Street : '1 Capitol Ave'; + City : 'Washington'; + State : 'DC'; + ZipCode : '10011-0001'; + Telephone : '301-222-1111'; + Age : 62); + + procedure AllocatePageBuffer(HeapToRemain : LongInt); + var + NumberOfPages : Word; + begin + NumberOfPages := BTInitIsam(NoNet, HeapToRemain, 0); + if not IsamOK then begin + {Insufficient memory} + Halt; + end; + end; + + function CreateFile : Boolean; + var + IID : IsamIndDescr; + begin + IID[1].KeyL := Key1Len; IID[1].AllowDupK := False; + IID[2].KeyL := Key2Len; IID[2].AllowDupK := True; + IID[3].KeyL := Key3Len; IID[3].AllowDupK := True; + BTCreateFileBlock('TEST', SizeOf(PersonDef), 3, IID); + CreateFile := IsamOK; + end; + + function OpenFile : Boolean; + begin + BTOpenFileBlock(PF, 'TEST', False, False, False, BTNetSupported <> NoNet); + if not IsamOK then begin + OpenFile := False; + {Error reporting code that examines + can go here. Corrective action may + be taken, for example by reconstructing a defective + index file as described in Section 6.D.} + Exit; + end else + OpenFile := True; + end; + + function CloseFile : Boolean; + begin + BTCloseFileBlock(PF); + if not IsamOK then begin + CloseFile := False; + {Error handling} + Exit; + end else + CloseFile := True; + end; + + function StUpcase(S : String) : String; + var + I : Integer; + begin + for I := 1 to Length(S) do + S[I] := Upcase(S[I]); + StUpcase := S; + end; + + function Pad(S : String; Len : Byte) : String; + var + SLen : Byte absolute S; + begin + if SLen > Len then + SLen := Len + else + while SLen < Len do + S := S+' '; + Pad := S; + end; + + {$F+} {Routine should be global} + function CreateKey(var P; KeyNr : Integer) : IsamKeyStr; + begin + with PersonDef(P) do + case KeyNr of + 1 : CreateKey := StUpcase(Pad(LastName, 20)+Pad(FirstName, 10)); + 2 : CreateKey := Copy(ZipCode, 1, 5); + 3 : CreateKey := Copy(Telephone, 1, 15); + else + CreateKey := ''; + end; + end; + + function YesNo(Prompt : String) : Boolean; + var + Done : Boolean; + S : string[1]; + begin + Done := False; + repeat + Write(Prompt); + ReadLn(S); + if Length(S) > 0 then + case Upcase(S[1]) of + 'Y' : begin + Done := True; + YesNo := True; + end; + 'N' : begin + Done := True; + YesNo := False; + end; + end; + until Done; + end; + + const + MaxRetries = 10; + RetryCount : Integer = 0; + + function IsLockError(Ask : Boolean) : Boolean; + begin + if IsamOK or (BTIsamErrorClass <> 2) then begin + {No error, or non-locking error} + IsLockError := False; + {Reset retry count} + RetryCount := 0; + end else begin + {Lock error} + IsLockError := True; + inc(RetryCount); + if RetryCount > MaxRetries then begin + {Out of retries} + if not Ask then + {Abort the operation without even asking} + IsLockError := False + else if not YesNo('Lock error. Try again?') then + {Abort the operation if the user says to do so} + IsLockError := False; + {Reset retry count} + RetryCount := 0; + end; + end; + end; + + procedure UndoAdd(P : PersonDef; RefNr : LongInt; LastKey : Integer); + var + KeyNr : Integer; + Key : IsamKeyStr; + begin + for KeyNr := 1 to LastKey do begin + Key := CreateKey(P, KeyNr); + BTDeleteKey(PF, KeyNr, RefNr, Key); + if not IsamOK then + {Abort: too many errors} + Halt; + end; + end; + + function AddRecord(P : PersonDef) : Boolean; + var + KeyNr : Integer; + RefNr : LongInt; + Key : IsamKeyStr; + begin + AddRecord := False; + + {Lock the database for a safe add} + repeat + BTLockFileBlock(PF); + until not IsLockError(True); + + BTAddRec(PF, RefNr, P); + if not IsamOK then begin + {Error handling} + BTUnLockFileBlock(PF); + Exit; + end; + for KeyNr := 1 to BTNrOfKeys(PF) do begin + Key := CreateKey(P, KeyNr); + BTAddKey(PF, KeyNr, RefNr, Key); + if not IsamOK then begin + {Remove keys added so far} + UndoAdd(P, RefNr, KeyNr-1); + {Remove the new record} + BTDeleteRec(PF, RefNr); + {Error handling} + BTUnLockFileBlock(PF); + Exit; + end; + end; + + BTUnLockFileBlock(PF); + AddRecord := IsamOK; + end; + + procedure SetMaxError; + var + ErrorClass : Integer; + begin + ErrorClass := BTIsamErrorClass; + if ErrorClass > MaxError then + MaxError := ErrorClass; + end; + + procedure UpdateUnlock(RefNr : LongInt); + begin + if BTFileBlockIsLocked(PF) then begin + BTUnlockFileBlock(PF); + if not IsamOK then + {Hardware failure? shouldn't happen} + SetMaxError; + end; + if BTRecIsLocked(PF, RefNr) then begin + BTUnlockRec(PF, RefNr); + if not IsamOK then + {Hardware failure? shouldn't happen} + SetMaxError; + end; + end; + + function UpdateLock(RefNr : LongInt) : Boolean; + begin + UpdateLock := False; + {Record locking is needed only if the application uses + record locks elsewhere} + BTLockRec(PF, RefNr); + if not IsamOK then begin + {Record could not be locked} + SetMaxError; + Exit; + end; + {Lock the fileblock} + BTLockFileBlock(PF); + if not IsamOK then begin + {FileBlock could not be locked} + SetMaxError; + UpdateUnlock(RefNr); + Exit; + end; + UpdateLock := True; + end; + + function MatchRecord(P1, P2 : PersonDef) : Boolean; + begin + {Return true if P1 and P2 are the same} + MatchRecord := True; + end; + + function DeleteRecord(P : PersonDef; RefNr : LongInt) : Integer; + var + KeyNr : Integer; + TempP : PersonDef; + begin + {At this point, the record to be deleted has already been read into + record P, and the user has verified that a deletion is to occur.} + + {MaxError is the highest error class encountered} + MaxError := 0; + + {Lock the record and the fileblock} + if not UpdateLock(RefNr) then begin + {Couldn't lock} + DeleteRecord := MaxError; + Exit; + end; + + {Get the record again to see if it still matches the original} + BTGetRec(PF, RefNr, TempP, False); + if not IsamOK then begin + {Shouldn't happen} + SetMaxError; + UpdateUnlock(RefNr); + DeleteRecord := MaxError; + Exit; + end; + + if TempP.Del <> 0 then begin + {Record was already deleted. That's ok since we wanted to delete it also} + UpdateUnlock(RefNr); + DeleteRecord := MaxError; + Exit; + end; + + if not MatchRecord(P, TempP) then begin + {Record was modified in the meantime. Return a "warning" error class} + MaxError := 1; + UpdateUnlock(RefNr); + DeleteRecord := MaxError; + Exit; + end; + + {Finally perform the deletion} + for KeyNr := 1 to BTNrOfKeys(PF) do begin + BTDeleteKey(PF, KeyNr, RefNr, CreateKey(P, KeyNr)); + if not IsamOK then + if IsamError = 10220 then + {Key already deleted. Shouldn't happen, but it's still ok if so} + else begin + {Error handling} + SetMaxError; + UpdateUnlock(RefNr); + DeleteRecord := MaxError; + Exit; + end; + end; + BTDeleteRec(PF, RefNr); + if not IsamOK then + SetMaxError; + + {Unlock the record and the fileblock} + UpdateUnlock(RefNr); + DeleteRecord := MaxError; + end; + + function CheckKeys(P : PersonDef) : Boolean; + begin + {Verify that new record has valid keys} + CheckKeys := True; + end; + + function ModifyRecord(P, POld : PersonDef; RefNr : LongInt) : Integer; + var + KeyNr : Integer; + TempP : PersonDef; + begin + {At this point, the user has modified the record. The new value is + stored in P and its previous value is stored in POld.} + + ModifyRecord := 0; + + if MatchRecord(P, POld) then + {No change, just exit} + Exit; + if not CheckKeys(P) then begin + {Invalid keys, perhaps empty name fields} + ModifyRecord := KeyError; + Exit; + end; + + {MaxError is the highest error class encountered} + MaxError := 0; + + {Lock the record and the Fileblock} + if not UpdateLock(RefNr) then begin + {Couldn't lock} + ModifyRecord := MaxError; + Exit; + end; + + {Get the record again to see if it still matches the original} + BTGetRec(PF, RefNr, TempP, False); + if not IsamOK then begin + {Shouldn't happen, but just in case} + SetMaxError; + UpdateUnlock(RefNr); + ModifyRecord := MaxError; + Exit; + end; + + if TempP.Del <> 0 then begin + {Record was deleted in the meantime} + MaxError := DeletedError; + UpdateUnlock(RefNr); + ModifyRecord := MaxError; + Exit; + end; + + if not MatchRecord(POld, TempP) then begin + {Record was modified in the meantime} + MaxError := ModifiedError; + UpdateUnlock(RefNr); + ModifyRecord := MaxError; + Exit; + end; + + {Finally perform the update} + BTPutRec(PF, RefNr, P, False); + if not IsamOK then begin + {Error handling} + SetMaxError; + UpdateUnlock(RefNr); + ModifyRecord := MaxError; + Exit; + end; + + for KeyNr := 1 to BTNrOfKeys(PF) do begin + {Update modified keys} + if CreateKey(P, KeyNr) <> CreateKey(POld, KeyNr) then begin + BTDeleteKey(PF, KeyNr, RefNr, CreateKey(POld, KeyNr)); + if IsamOK then + BTAddKey(PF, KeyNr, RefNr, CreateKey(P, KeyNr)); + if not IsamOK then begin + {Error handling} + SetMaxError; + UpdateUnlock(RefNr); + ModifyRecord := MaxError; + Exit; + end; + end; + end; + + UpdateUnlock(RefNr); + ModifyRecord := MaxError; + end; + + function FindRecord(var P : PersonDef; + var RefNr : LongInt; + KeyNr : Integer; + var Key : IsamKeyStr) : Boolean; + begin + FindRecord := False; + repeat + BTSearchKey(PF, KeyNr, RefNr, Key); + until not IsLockError(True); + if not IsamOK then begin + {Key not found, program error, or abortive locking error} + Exit; + end; + repeat + BTGetRec(PF, RefNr, P, False); + until not IsLockError(True); + if not IsamOK then begin + {Error handling} + Exit; + end; + FindRecord := True; + end; + + function NextPrevRecord(var P : PersonDef; + var RefNr : LongInt; + KeyNr : Integer; + var Key : IsamKeyStr; + Next : Boolean) : Boolean; + begin + NextPrevRecord := False; + if Next then begin + repeat + BTNextKey(PF, KeyNr, RefNr, Key); + until not IsLockError(True); + if not IsamOK and (IsamError = 10250) then + {There was no next key. Move to first key in the file} + BTNextKey(PF, KeyNr, RefNr, Key); + end else begin + repeat + BTPrevKey(PF, KeyNr, RefNr, Key); + until not IsLockError(True); + if not IsamOK and (IsamError = 10260) then + {There was no previous key. Move to last key in file} + BTPrevKey(PF, KeyNr, RefNr, Key); + end; + if not IsamOK then + Exit; + repeat + BTGetRec(PF, RefNr, P, False); + until not IsLockError(True); + if not IsamOK then begin + {Error handling} + Exit; + end; + NextPrevRecord := True; + end; + +begin + WriteLn('This program is just a collection of example routines'); + WriteLn('See SIMPDEMO.PAS or NETDEMO.PAS for working demo programs'); +end. diff --git a/src/wc_sdk/numkey32.pas b/src/wc_sdk/numkey32.pas new file mode 100644 index 0000000..c57adce --- /dev/null +++ b/src/wc_sdk/numkey32.pas @@ -0,0 +1,821 @@ +{********************************************************************} +{* NUMKEY32.PAS - numeric to key conversion *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{Notes: 1. Real type support has been discarded + 2. The CStyle key routines not implemented yet + 3. IntToKey and KeyToInt are now called Int16ToKey and KeyToInt16 + 4. LongToKey and KeyToLong are now called Int32ToKey and KeyToInt32 + 5. There is no support yet for 32-bit unsigned integers} + +{$IFNDEF Win32} + !! Error - this unit can only be compiled for 32-bit +{$ENDIF} + +unit NumKey32; + +{$A-} {No alignment} +{$H-} {No long string support--all short string routines} +{$V-} {No var string checking} + +interface + +type + String1 = String[1]; + String2 = String[2]; + String4 = String[4]; + String5 = String[5]; + String6 = String[6]; + String7 = String[7]; + String8 = String[8]; + String9 = String[9]; + String10 = String[10]; + +{---routines for numeric conversions---} +function ShortToKey(S : ShortInt) : String1; + {-Convert a shortint to a string} + +function KeyToShort(const S : String1) : ShortInt; + {-Convert a string to a shortint} + +function ByteToKey(B : Byte) : String1; + {-Convert a byte to a string} + +function KeyToByte(const S : String1) : Byte; + {-Convert a string to a byte} + +function Int16ToKey(I : SmallInt) : String2; + {-Convert an integer to a string} + +function KeyToInt16(const S : String2) : SmallInt; + {-Convert a string to an integer} + +function WordToKey(W : Word) : String2; + {-Convert a word to a string} + +function KeyToWord(const S : String2) : Word; + {-Convert a string to a word} + +function Int32ToKey(L : LongInt) : String4; + {-Convert a longint to a string} + +function KeyToInt32(const S : String4) : LongInt; + {-Convert a string to a longint} + +function BcdToKey(var B) : String10; {!!.53} + {-Convert a BCD real to a string} + +procedure KeyToBcd(S : String10; var B); {!!.53} + {-Convert a string to a BCD real} + +{Note: + Although the following two routines work with Extendeds, you can also use + them with singles, doubles, and comps. You may use any of the following + string types to hold the results of ExtToKey without losing any precision: + + Single : String5 (min) - String10 (max) + Double : String9 (min) - String10 (max) + Extended : String10 (min/max) + Comp : String10 (min/max) + + Slightly shorter strings (one less than the recommended minimum) may be used + for singles, doubles, and extendeds if you are willing to sacrifice some + precision, however. We strongly recommend that you always use a String10 for + comps. +} +function ExtToKey(E : Extended) : String10; + {-Convert an extended to a string} + +function KeyToExt(S : String10) : Extended; + {-Convert a string to an extended} + + +{---routines for packing/unpacking keys---} +function Pack4BitKey(Src : string; Len : Byte) : string; + {-Pack the Source string into sequences of 4 bits (max length = Len). + The following characters are mapped to 1-15, respectively, all others + to 0: '(', ')', '+', '-', '.', '0'..'9'.} + +function Pack5BitKeyUC(Src : string; Len : Byte) : string; + {-Pack the Source string into sequences of 5 bits (max length = Len). + Characters from 'a' to 'z' converted to upper case, then characters from + 'A' to 'Z' are mapped to 1-26, all others to 0.} + +function Pack6BitKeyUC(Src : string; Len : Byte) : string; + {-Pack the Source string into sequences of 6 bits (max length = Len). + Characters from 'a' to 'z' converted to upper case, then characters from + '!' to '_' are mapped to 1-63, all others to 0.} + +function Pack6BitKey(Src : string; Len : Byte) : string; + {-Pack the Source string into sequences of 6 bits (max length = Len). + Characters from '0'-'9' mapped to 1-10, 'A'-'Z' to 11-36, 'a'-'z' to + 37-62, all others to 0.} + +function Unpack4BitKey(Src : string) : string; + {-Unpack a key created by Pack4BitKey} + +function Unpack5BitKeyUC(Src : string) : string; + {-Unpack a key created by Pack5BitKeyUC} + +function Unpack6BitKeyUC(Src : string) : string; + {-Unpack a key created by Pack6BitKeyUC} + +function Unpack6BitKey(Src : string) : string; + {-Unpack a key created by Pack6BitKey} + + +{---miscellaneous routines---} +function DescendingKey(S : string; MaxLen : Byte) : string; + {-Invert values in S to allow descending sorts, pad to MaxLen with #$FF} + + +implementation + +type + nkBCD = array[1..10] of Byte; + +const + Pack4Table : array [0..17] of byte = + {( ) * + , - . / 0 1 2 3 4 5 6 7 8 9} + (1, 2, 0, 3, 0, 4, 5, 0, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15); + Unpack4Table : array [0..15] of char = + (' ', '(', ')', '+', '-', '.', '0', '1', + '2', '3', '4', '5', '6', '7', '8', '9'); + + +{===Helper routines==================================================} +procedure ReverseBytes(var V; Size : Word); assembler; + {-Reverse the ordering of bytes from V[1] to V[Size]. Size must be >= 2.} + asm + push ebx + movzx edx, dx + mov ecx, eax + add ecx, edx + dec ecx + shr edx, 1 + @@Again: + mov bl, [eax] + xchg bl, [ecx] + mov [eax], bl + inc eax + dec ecx + dec edx + jnz @@Again + pop ebx + end; +{--------} +procedure ToggleBits(var V; Size : Word); assembler; + {-Toggle the bits from V[1] to V[Size]} + asm + movzx edx, dx + @@Again: + not byte ptr [eax] + inc eax + dec edx + jnz @@Again + end; +{--------} +function SwapWord(L : LongInt) : LongInt; assembler; + {-Swap low- and high-order words of L} + asm + rol eax, 16 + end; +{--------} +procedure ZeroPad(var S : ShortString; Len : Word); + {-Pad S to length Len with 0's} + var + SLen : Byte absolute S; + begin + if SLen < Len then + begin + FillChar(S[Succ(SLen)], Len-SLen, 0); + SLen := Len; + end; + end; +{--------} +function Pack4Prim(C : byte) : byte; assembler; + asm + cmp al, '(' {less than '('?} + jb @@ZeroIt {yes, return zero} + cmp al, '9' {greater than '9'?} + ja @@ZeroIt {yes, return zero} + push ebx {save ebx} + movzx ebx, al {convert character in al} + add ebx, OFFSET Pack4Table + mov al, [ebx - '('] + pop ebx {restore ebx} + jmp @@Exit {exit} + @@ZeroIt: + xor al, al {return zero: is out of range} + @@Exit: + end; +{--------} +function Pack5UCPrim(C : byte) : byte; assembler; + asm + cmp al, 'z' {greater than 'z'?} + ja @@ZeroIt {yes, return zero} + cmp al, 'a' {less than 'a'?} + jb @@CheckAtoZ {yes, go check on 'A'-'Z'} + sub al, 96 {convert to 1..26} + jmp @@Exit {exit} + @@CheckAtoZ: + cmp al, 'Z' {greater than 'Z'?} + ja @@ZeroIt {yes, return zero} + cmp al, 'A' {less than 'A'?} + jb @@ZeroIt {yes, return zero} + sub al, 64 {convert to 1..26} + jmp @@Exit {exit} + @@ZeroIt: + xor al, al {return zero: is out of range} + @@Exit: + end; +{--------} +function Pack6Prim(C : byte) : byte; assembler; + asm + cmp al, 'z' {greater than 'z'?} + ja @@ZeroIt {yes, return zero} + cmp al, 'a' {less than 'a'?} + jb @@CheckAtoZ {yes, go check on 'A'-'Z'} + sub al, 60 {convert to 37..62} + jmp @@Exit {exit} + @@CheckAtoZ: + cmp al, 'Z' {greater than 'Z'?} + ja @@ZeroIt {yes, return zero} + cmp al, 'A' {less than 'A'?} + jb @@Check0to9 {yes, go check on '0'-'9'} + sub al, 54 {convert to 11..36} + jmp @@Exit {exit} + @@Check0to9: + cmp al, '9' {greater than '9'?} + ja @@ZeroIt {yes, return zero} + cmp al, '0' {less than '0'?} + jb @@ZeroIt {yes, return zero} + sub al, 47 {convert to 1..10} + jmp @@Exit {exit} + @@ZeroIt: + xor al, al {return zero: is out of range} + @@Exit: + end; +{--------} +function Pack6UCPrim(C : byte) : byte; assembler; + asm + cmp al, '_' {greater than '_'?} + ja @@CheckAtoZ {yes, go check on 'a'-'z'} + cmp al, '!' {less than '!'?} + jb @@ZeroIt {yes, return zero} + sub al, 32 {convert to 1..63} + jmp @@Exit {exit} + @@CheckAtoZ: + cmp al, 'z' {greater than 'z'?} + ja @@ZeroIt {yes, return zero} + cmp al, 'a' {less than 'a'?} + jb @@ZeroIt {yes, return zero} + sub al, 64 {convert to 33..58} + jmp @@Exit {exit} + @@ZeroIt: + xor al, al {return zero: is out of range} + @@Exit: + end; +{--------} +function Unpack4Prim(C : byte) : byte; assembler; + asm + push ebx {save ebx} + movzx ebx, al {convert character in al} + add ebx, OFFSET Unpack4Table + mov al, [ebx] + pop ebx {restore ebx} + end; +{--------} +function Unpack5UCPrim(C : byte) : byte; assembler; + asm + or al, al {zero?} + je @@Space {yes, return space} + add al, 32 {map to 'A'-'Z'} + @@Space: + add al, 32 + end; +{--------} +function Unpack6UCPrim(C : byte) : byte; assembler; + asm + add al, 32 {map to ' '-'Z'} + end; +{--------} +function Unpack6Prim(C : byte) : byte; assembler; + asm + or al, al {zero?} + jz @@Space {yes, return space} + sub al, 10 {check for 1-10} + jnle @@CheckAToZ {no, go check for A-Z code} + add al, 57 {convert to '0'..'9'} + jmp @@Exit {exit} + @@Space: + mov al, 32 {return space} + jmp @@Exit + @@CheckAToZ: + sub al, 26 {convert 1..52 to 'A'..'Z', 'a'..'z'} + jnle @@ItsaToz + sub al, 6 + @@ItsaToz: + add al, 96 + @@Exit: + end; +{--------} +procedure GenericPack; assembler; + asm + {eax = Src; dl = Len; dh = BitsPerChar; ecx = result; ebx = pack function} + {Note: references to [esp+4] are to the conversion routine} + { to [esp] are the address of the final char in result} + push edi {save esi, edi} + push esi + push ebx {save pack function on stack} + mov esi, eax {esi => Src} + mov edi, ecx {edi => result} + + xor eax, eax {set eax to zero} + mov al, dl {al is length of result} + mov [edi], al {store in result} + inc edi {point to next dest char} + add eax, edi {calc final address of result on stack} + push eax + + mov dl, 8 {dl = bytes per char delta} + sub dl, dh + + mov bl, [esi] {bl = # chars in Src} + inc esi + xor bh, bh {bh = # bits in ah} + + @@Main: + cmp edi, [esp] {is result string full?} + jae @@Exit {yes, exit} + or bl, bl {any chars left in Src} + jz @@Finish {no, finish off the result string} + mov al, [esi] {get next char from Src} + inc esi + dec bl {decrement number of chars left in Src} + call dword ptr [esp+4]{convert it} + mov cl, dl {shift bottom of al to top of al} + shl al, cl + + mov ch, dh {ch = bits per char} + @@BitLoop: + cmp bh, 8 {8 bits set in ah yet?} + jb @@NextBit {no, go add next one} + mov [edi], ah {store ah in result string} + inc edi + xor bh, bh {set bits in ah to zero} + @@NextBit: + rol al, 1 {get next bit from top of al into CF} + rcl ah, 1 {push CF into bottom of ah} + inc bh {increment number of bits in ah} + dec ch {decrement bits to go} + jnz @@BitLoop {continue if more bits} + jmp @@Main {go get next character} + + @@Finish: {time to finish up} + or bh, bh {any bits left in ah?} + jz @@ZeroPad {no, go pad result string with zeros} + mov cl, 8 {calc number of bits to stuff ah with} + sub cl, bh + shl ah, cl {..and do it} + mov [edi], ah {store ah in result string} + inc edi + + @@ZeroPad: {time to pad result string with zero bytes} + mov ecx, [esp] {calculate the number of characters} + sub ecx, edi + xor eax, eax + cld + rep stosb {pad with #0s} + + @@Exit: + add esp, 8 {toss local variables} + pop esi {restore edi, esi and ebx} + pop edi + pop ebx + end; +{--------} +procedure GenericUnpack; assembler; + asm + {eax = Src; edx = result; cl = BitsPerChar; ebx = unpack function} + push edi {save esi, edi} + push esi + push edx {save address of result[0]} + mov esi, eax {esi => Src} + mov edi, edx {edi => result} + mov dh, cl {dh = bits per character} + mov ecx, ebx {ecx = conversion routine} + + mov bl, [esi] {bl = length of Src} + inc esi + xor bh, bh {bh = number of bits in ah} + + @@Main: + or bl, bl {any characters left?} + jz @@Finish {no, go finish off} + + mov dl, dh {cl = bits per character} + xor al, al {set new character to zero} + + @@BitLoop: + or bh, bh {any bits left in ah?} + jnz @@Next {yes, go rotate next bit} + mov ah, [esi] {get next character from Src} + inc esi + dec bl {decrement number of chars left in Src} + mov bh, 8 {another 8 bits to go through} + @@Next: + rol ah, 1 {get highest bit in ah into CF} + rcl al, 1 {rotate CF into bottom of al} + dec bh {decrement bits left in ah} + dec dl {decrement bits left to go for this char} + jnz @@BitLoop + + call ecx {convert al} + inc edi {put converted char into result string} + mov [edi], al + jmp @@Main {go back for next conversion} + + @@Finish: + cmp bh, dh {is there a complete char in ah?} {!!.55} + jb @@Exit {no, go write length byte} + mov esi, ecx {esi = conversion routine} {!!.55} + mov cl, 8 {calc shift value} + sub cl, dh {!!.55} + mov al, ah {set unconverted char in al} + shr al, cl + call esi {convert al} {!!.55} + inc edi {put converted char into result string} + mov [edi], al + + @@Exit: + mov eax, edi {calc length} + pop edi + sub eax, edi + mov [edi], al {store length} + + pop esi {restore edi, esi and ebx} + pop edi + pop ebx + end; +{====================================================================} + + +{===Packed keys generation===========================================} +function Pack4BitKey(Src : string; Len : Byte) : string; assembler; + asm + push ebx + mov dh, $04 + lea ebx, Pack4Prim + jmp GenericPack + end; +{--------} +function Pack5BitKeyUC(Src : string; Len : Byte) : string; assembler; + asm + push ebx + mov dh, $05 + lea ebx, Pack5UCPrim + jmp GenericPack + end; +{--------} +function Pack6BitKeyUC(Src : string; Len : Byte) : string; assembler; + asm + push ebx + mov dh, $06 + lea ebx, Pack6UCPrim + jmp GenericPack + end; +{--------} +function Pack6BitKey(Src : string; Len : Byte) : string; assembler; + asm + push ebx + mov dh, $06 + lea ebx, Pack6Prim + jmp GenericPack + end; +{====================================================================} + + +{===Packed keys decompiling==========================================} +function Unpack4BitKey(Src : string) : string; assembler; + asm + push ebx + mov cl, $04 + lea ebx, Unpack4Prim + jmp GenericUnpack + end; +{--------} +function Unpack5BitKeyUC(Src : string) : string; assembler; + asm + push ebx + mov cl, $05 + lea ebx, Unpack5UCPrim + jmp GenericUnpack + end; +{--------} +function Unpack6BitKeyUC(Src : string) : string; assembler; + asm + push ebx + mov cl, $06 + lea ebx, Unpack6UCPrim + jmp GenericUnpack + end; +{--------} +function Unpack6BitKey(Src : string) : string; assembler; + asm + push ebx + mov cl, $06 + lea ebx, Unpack6Prim + jmp GenericUnpack + end; +{====================================================================} + + + +{===Numeric to string conversions====================================} +function ShortToKey(S : ShortInt) : String1; + {-Convert a shortint to a string} + begin + Result[0] := #1; + Result[1] := Char(byte(S) xor $80); {!!.55} + end; +{--------} +function KeyToShort(const S : String1) : ShortInt; + {-Convert a string to a shortint} + begin + Result := ShortInt(byte(S[1]) xor $80); {!!.55} + end; +{--------} +function ByteToKey(B : Byte) : String1; + {-Convert a byte to a string} + begin + Result[0] := #1; + Result[1] := Char(B); + end; +{--------} +function KeyToByte(const S : String1) : Byte; + {-Convert a string to a byte} + begin + Result := Byte(S[1]); + end; +{--------} +function Int16ToKey(I : SmallInt) : String2; + {-Convert a 16-bit integer to a string} + var + LResult : record + Len : Byte; + RI : Word; + end absolute Result; + begin + LResult.Len := 2; + LResult.RI := Swap(Word(I) xor $8000); {!!.55} + end; +{--------} +function KeyToInt16(const S : String2) : SmallInt; + {-Convert a string to an integer} {rewritten !!.56} +asm + mov ax, [eax+1] + xchg ah, al + xor ax, $8000 +end; +{--------} +function WordToKey(W : Word) : String2; + {-Convert a word to a string} + var + LResult : record + Len : Byte; + RW : Word; + end absolute Result; + begin + LResult.Len := 2; + LResult.RW := Swap(W); + end; +{--------} +function KeyToWord(const S : String2) : Word; + {-Convert a string to a word} + var + Temp : record + Len : Byte; + W : Word; + end absolute S; + begin + Result := Swap(Temp.W); + end; +{--------} +function Int32ToKey(L : LongInt) : String4; + {-Convert a 32-bit integer to a string} + var + LRec : record + L1 : Word; + L2 : Word; + end absolute L; + LResult : record + Len : Byte; + W1, W2 : Word; + end absolute Result; + begin + L := L xor longint($80000000); {!!.55} + LResult.Len := 4; + LResult.W1 := Swap(LRec.L2); + LResult.W2 := Swap(LRec.L1); + end; +{--------} +function KeyToInt32(const S : String4) : LongInt; + {-Convert a string to a 32-bit integer} + var + Temp : record case Byte of + 0 : (Len : Byte; W1, W2 : Word); + 1 : (X : Byte; L : LongInt); + end absolute S; + LResult : record + case byte of + 0 : (W1, W2 : word); + 1 : (L : longint); + end; + begin + LResult.W1 := Swap(Temp.W2); + LResult.W2 := Swap(Temp.W1); + Result := LResult.L xor longint($80000000); {!!.55} + end; +{--------} +function BcdToKey(var B) : String10; + {-Convert a BCD real to a string} + var + LResult : record + case byte of + 0 : (Len : Byte; BT : nkBCD); + 1 : (XXX, Exp, LSB : Byte); + end absolute Result; + BP : nkBCD absolute B; + begin + {regularize 0 values} + if BP[1] and $7F = 0 then + FillChar(BP, SizeOf(BP), 0); + + LResult.BT := BP; + + {put the mantissa into MSB->LSB order} + ReverseBytes(LResult.LSB, 9); + + {flip the sign bit} + LResult.Exp := LResult.Exp xor $80; + + if LResult.Exp and $80 = 0 then begin + ToggleBits(LResult.BT, 10); + LResult.Exp := LResult.Exp and $7F; + end; + + LResult.Len := 10; + end; +{--------} +procedure KeyToBcd(S : String10; var B); + {-Convert a string to a BCD real} + var + Temp : record case Byte of + 0 : (Len : Byte; BT : nkBCD); + 1 : (XXX, Exp, MSB : Byte); + end absolute S; + BR : nkBcd absolute B; + begin + {pad to proper length just in case} + ZeroPad(S, 10); + + {flip the sign bit} + Temp.Exp := Temp.Exp xor $80; + + if Temp.Exp and $80 <> 0 then begin + ToggleBits(Temp.BT, 10); + Temp.Exp := Temp.Exp or $80; + end; + + {put the mantissa back into LSB->MSB order} + ReverseBytes(Temp.MSB, 9); + + BR := Temp.BT; + end; +{--------} +function ExtToKey(E : Extended) : String10; + {-Convert an extended to a string} + var + LResult : record + case Byte of + 0 : (Len : Byte; EE : Extended); + 1 : (XXX, Exp : Byte); + 2 : (Str : String10); + end absolute Result; + begin + LResult.EE := E; + + {move the exponent to the front and put mantissa in MSB->LSB order} + ReverseBytes(LResult.EE, 10); + + {flip the sign bit} + LResult.Exp := LResult.Exp xor $80; + + if LResult.Exp and $80 = 0 then begin + ToggleBits(LResult.EE, 10); + LResult.Exp := LResult.Exp and $7F; + end; + + LResult.Len := 10; + end; +{--------} +function KeyToExt(S : String10) : Extended; + {-Convert a string to an extended} + var + Temp : record case Byte of + 0 : (Len : Byte; EE : Extended); + 1 : (XXX, Exp : Byte); + 2 : (Str : String10); + end absolute S; + begin + {pad to proper length just in case} + ZeroPad(S, 10); + + {flip the sign bit} + Temp.Exp := Temp.Exp xor $80; + + if Temp.Exp and $80 <> 0 then begin + ToggleBits(Temp.EE, 10); + Temp.Exp := Temp.Exp or $80; + end; + + {move the exponent back to the end and put mantissa in LSB->MSB order} + ReverseBytes(Temp.EE, 10); + + Result := Temp.EE; + end; +{====================================================================} + + + +{===Miscellaneous routines===========================================} +function DescendingKey(S : string; MaxLen : Byte) : string; assembler; + asm + {eax = S, dl = MaxLen, ecx = result string} + push esi {Save esi and edi} + push edi + mov esi, eax {esi => S} + mov edi, ecx {edi => result string} + movzx edx, dl {edx = MaxLen} + xor eax, eax {eax = length of string} + mov al, [esi] + mov ecx, eax {ecx = length of string} + cmp ecx, edx {length of result string = max(ecx, edx)} + ja @@SetLength + mov eax, edx + @@SetLength: + mov [edi], al + sub edx, ecx {calc amount of padding} + or ecx, ecx {is length of S zero} + jz @@Pad {yes, jump to padding routine} + @@Again: + inc esi {point to next source character} + inc edi {point to next destination character} + mov al, [esi] {get next character} + not al {convert} + mov [edi], al {put next character} + dec ecx {any more characters in source string?} + jnz @@Again {yes, go do next} + @@Pad: + cmp edx, 0 {any padding to do?} + jle @@Exit {no, go tidy up} + inc edi {point at next destination character} + mov al, $FF {replicate required number of $FFs to pad} + mov ecx, edx + cld + rep stosb + @@Exit: + pop edi {restore esi and edi} + pop esi + end; + + +end. diff --git a/src/wc_sdk/numkeys.pas b/src/wc_sdk/numkeys.pas new file mode 100644 index 0000000..5c8ac36 --- /dev/null +++ b/src/wc_sdk/numkeys.pas @@ -0,0 +1,1034 @@ +{********************************************************************} +{* NUMKEYS.PAS - numeric to key conversion *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF CanAllowOverlays} + {$F+,O+,A-} +{$ENDIF} +{$IFDEF UseSymFlex} + {$N+} +{$ENDIF} + +{$IFNDEF FPC} +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} +{$ENDIF} + +Unit + Numkeys; + +interface + +type + String1 = String[1]; + String2 = String[2]; + String4 = String[4]; + String5 = String[5]; + String6 = String[6]; + String7 = String[7]; + String8 = String[8]; + String9 = String[9]; + String10 = String[10]; + +{---------------- routines for numeric conversions ----------------} + +function ShortToKey(S : ShortInt) : String1; + {-Convert a shortint to a string} + +function KeyToShort(S : String1) : ShortInt; + {-Convert a string to a shortint} + +function ByteToKey(B : Byte) : String1; {!!.41} + {-Convert a byte to a string} + +function KeyToByte(S : String1) : Byte; {!!.41} + {-Convert a string to a byte} + +function IntToKey(I : Integer) : String2; + {-Convert an integer to a string} + +function KeyToInt(S : String2) : Integer; + {-Convert a string to an integer} + +function WordToKey(W : Word) : String2; + {-Convert a word to a string} + +function KeyToWord(S : String2) : Word; + {-Convert a string to a word} + +function LongToKey(L : LongInt) : String4; + {-Convert a longint to a string} + +function KeyToLong(S : String4) : LongInt; + {-Convert a string to a longint} + +function RealToKey(R : Real) : String6; + {-Convert a real to a string} + +function KeyToReal(S : String6) : Real; + {-Convert a string to a real} + +function BcdToKey(var B) : String10; + {-Convert a BCD real to a string} + +procedure KeyToBcd(S : String10; var B); + {-Convert a string to a BCD real} + +{$IFOPT N+} + +{Note: + Although the following two routines work with Extendeds, you can also use + them with singles, doubles, and comps. You may use any of the following + string types to hold the results of ExtToKey without losing any precision: + + Single : String5 (min) - String10 (max) + Double : String9 (min) - String10 (max) + Extended : String10 (min/max) + Comp : String10 (min/max) + + Slightly shorter strings (one less than the recommended minimum) may be used + for singles, doubles, and extendeds if you are willing to sacrifice some + precision, however. We strongly recommend that you always use a String10 for + comps. +} +function ExtToKey(E : Extended) : String10; + {-Convert an extended to a string} + +function KeyToExt(S : String10) : Extended; + {-Convert a string to an extended} + +{$ENDIF} + +{---------------- routines for packing/unpacking keys ----------------} + +function Pack4BitKey(Src : string; Len : Byte) : string; + {-Pack the Source string into sequences of 4 bits (max length = Len). + The following characters are mapped to 1-15, respectively, all others + to 0: '(', ')', '+', '-', '.', '0'..'9'.} + +function Pack5BitKeyUC(Src : string; Len : Byte) : string; + {-Pack the Source string into sequences of 5 bits (max length = Len). + Characters from 'a' to 'z' converted to upper case, then characters from + 'A' to 'Z' are mapped to 1-26, all others to 0.} + +function Pack6BitKeyUC(Src : string; Len : Byte) : string; + {-Pack the Source string into sequences of 6 bits (max length = Len). + Characters from 'a' to 'z' converted to upper case, then characters from + '!' to '_' are mapped to 1-63, all others to 0.} + +function Pack6BitKey(Src : string; Len : Byte) : string; + {-Pack the Source string into sequences of 6 bits (max length = Len). + Characters from '0'-'9' mapped to 1-10, 'A'-'Z' to 11-36, 'a'-'z' to + 37-62, all others to 0.} + +function Unpack4BitKey(Src : string) : string; + {-Unpack a key created by Pack4BitKey} + +function Unpack5BitKeyUC(Src : string) : string; + {-Unpack a key created by Pack5BitKeyUC} + +function Unpack6BitKeyUC(Src : string) : string; + {-Unpack a key created by Pack6BitKeyUC} + +function Unpack6BitKey(Src : string) : string; + {-Unpack a key created by Pack6BitKey} + +{---------------- miscellaneous routines ----------------} + +function DescendingKey(S : string; MaxLen : Byte) : string; + {-Invert values in S to allow descending sorts, pad to MaxLen with #$FF} + +function CStyleNumKey(S : String) : String; {!!.41} + {-Convert Pascal-style numkey S into a C-style numkey, compatible with ASCIIZ} + +function PascalStyleNumKey(S : String) : String; {!!.41} + {-Convert C-style numkey S into a Pascal-style numkey} + +function CStyleDescendingKey(S : string; MaxLen : byte) : string; {!!.41} + {-Convert S to a descending key, using C-style algorithm} + + {=========================================================================} + +implementation + +{$IFDEF FPC} +const + Pack4Table : array [0..17] of byte = + {( ) * + , - . / 0 1 2 3 4 5 6 7 8 9} + (1, 2, 0, 3, 0, 4, 5, 0, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15); + Unpack4Table : array [0..15] of char = + (' ', '(', ')', '+', '-', '.', '0', '1', + '2', '3', '4', '5', '6', '7', '8', '9'); + + procedure ReverseBytes(var V; Size : Word); + var + P : PByte; + I : Word; + T : Byte; + begin + P := @V; + for I := 0 to (Size div 2) - 1 do begin + T := P[I]; + P[I] := P[Size - 1 - I]; + P[Size - 1 - I] := T; + end; + end; + + procedure ToggleBits(var V; Size : Word); + var + P : PByte; + I : Word; + begin + P := @V; + for I := 0 to Size - 1 do + P[I] := not P[I]; + end; + + function SwapWord(L : LongInt) : LongInt; + begin + SwapWord := (L shr 16) or (L shl 16); + end; + + function FirstRotation(W : Word) : Word; + var + AH, AL : Byte; + SignBit, LowBit : Byte; + begin + AL := Lo(W); + AH := Hi(W); + { xor ah,$80 - flip sign bit } + AH := AH xor $80; + { rol ah,1 - rotate sign bit (bit 7) into carry, bit 0 gets old bit 7 } + SignBit := (AH shr 7) and 1; + AH := (AH shl 1) or SignBit; + { rcr al,1 - rotate carry (SignBit) into AL bit 7, AL bit 0 goes to carry } + LowBit := AL and 1; + AL := (AL shr 1) or (SignBit shl 7); + { rcr ah,1 - rotate carry (LowBit) into AH bit 7, AH bit 0 goes to carry } + AH := (AH shr 1) or (LowBit shl 7); + FirstRotation := Word(AH) shl 8 + AL; + end; + + function SecondRotation(W : Word) : Word; + var + AH, AL : Byte; + HighBit, SignBit : Byte; + begin + AL := Lo(W); + AH := Hi(W); + { xor al,$80 - flip sign bit in AL } + AL := AL xor $80; + { rol ah,1 - rotate high bit of AH into carry } + HighBit := (AH shr 7) and 1; + AH := (AH shl 1) or HighBit; + { rcl al,1 - rotate carry into low bit of AL, sign bit out to carry } + SignBit := (AL shr 7) and 1; + AL := (AL shl 1) or HighBit; + { rcr ah,1 - rotate carry (sign bit) back into high bit of AH } + AH := (AH shr 1) or (SignBit shl 7); + SecondRotation := Word(AH) shl 8 + AL; + end; + + { Pack/Unpack primitive functions } + function Pack4Prim(C : Byte) : Byte; + begin + if (C < Ord('(')) or (C > Ord('9')) then + Pack4Prim := 0 + else + Pack4Prim := Pack4Table[C - Ord('(')]; + end; + + function Pack5UCPrim(C : Byte) : Byte; + begin + if (C >= Ord('a')) and (C <= Ord('z')) then + Pack5UCPrim := C - 96 + else if (C >= Ord('A')) and (C <= Ord('Z')) then + Pack5UCPrim := C - 64 + else + Pack5UCPrim := 0; + end; + + function Pack6UCPrim(C : Byte) : Byte; + begin + if (C >= Ord('a')) and (C <= Ord('z')) then + Pack6UCPrim := C - 64 { map to 33..58 } + else if (C >= Ord('!')) and (C <= Ord('_')) then + Pack6UCPrim := C - 32 { map to 1..63 } + else + Pack6UCPrim := 0; + end; + + function Pack6Prim(C : Byte) : Byte; + begin + if (C >= Ord('a')) and (C <= Ord('z')) then + Pack6Prim := C - 60 { map to 37..62 } + else if (C >= Ord('A')) and (C <= Ord('Z')) then + Pack6Prim := C - 54 { map to 11..36 } + else if (C >= Ord('0')) and (C <= Ord('9')) then + Pack6Prim := C - 47 { map to 1..10 } + else + Pack6Prim := 0; + end; + + function Unpack4Prim(C : Byte) : Byte; + begin + if C <= 15 then + Unpack4Prim := Ord(Unpack4Table[C]) + else + Unpack4Prim := Ord(' '); + end; + + function Unpack5UCPrim(C : Byte) : Byte; + begin + if C = 0 then + Unpack5UCPrim := Ord(' ') + else + Unpack5UCPrim := C + 64; { map to 'A'..'Z' } + end; + + function Unpack6UCPrim(C : Byte) : Byte; + begin + Unpack6UCPrim := C + 32; { map to ' '..'_' } + end; + + function Unpack6Prim(C : Byte) : Byte; + begin + if C = 0 then + Unpack6Prim := Ord(' ') + else if C <= 10 then + Unpack6Prim := C + 47 { map to '0'..'9' } + else if C <= 36 then + Unpack6Prim := C + 54 { map to 'A'..'Z' } + else + Unpack6Prim := C + 60; { map to 'a'..'z' } + end; + + type + TPackFunc = function(C : Byte) : Byte; + + { Generic bit-packing routine } + function GenericPack(var Src : string; Len : Byte; BitsPerChar : Byte; + PackFunc : TPackFunc) : string; + var + Result_ : string; + SrcIdx, DstIdx : Word; + Accum : Byte; { accumulator for bits } + AccumBits : Byte; { number of bits in accumulator } + CharVal : Byte; + Bit : Byte; + BitIdx : Byte; + begin + Result_[0] := Chr(Len); + SrcIdx := 1; + DstIdx := 1; + Accum := 0; + AccumBits := 0; + + while DstIdx <= Len do begin + if SrcIdx <= Length(Src) then begin + CharVal := PackFunc(Ord(Src[SrcIdx])); + Inc(SrcIdx); + end else + CharVal := 0; + + { feed BitsPerChar bits from CharVal (MSB first) into accumulator } + for BitIdx := BitsPerChar downto 1 do begin + Accum := (Accum shl 1) or ((CharVal shr (BitIdx - 1)) and 1); + Inc(AccumBits); + if AccumBits = 8 then begin + Result_[DstIdx] := Chr(Accum); + Inc(DstIdx); + Accum := 0; + AccumBits := 0; + if DstIdx > Len then Break; + end; + end; + end; + + { flush remaining bits } + if (AccumBits > 0) and (DstIdx <= Len) then begin + Accum := Accum shl (8 - AccumBits); + Result_[DstIdx] := Chr(Accum); + Inc(DstIdx); + end; + + { zero-pad remainder } + while DstIdx <= Len do begin + Result_[DstIdx] := #0; + Inc(DstIdx); + end; + + GenericPack := Result_; + end; + + { Generic bit-unpacking routine } + function GenericUnpack(var Src : string; BitsPerChar : Byte; + UnpackFunc : TPackFunc) : string; + var + Result_ : string; + SrcIdx, DstIdx : Word; + SrcByte : Byte; + SrcBitsLeft : Byte; + CharVal : Byte; + BitIdx : Byte; + begin + SrcIdx := 1; + DstIdx := 0; + SrcBitsLeft := 0; + SrcByte := 0; + + while SrcIdx <= Length(Src) do begin + CharVal := 0; + for BitIdx := 1 to BitsPerChar do begin + if SrcBitsLeft = 0 then begin + if SrcIdx > Length(Src) then begin + SrcByte := 0; + end else begin + SrcByte := Ord(Src[SrcIdx]); + Inc(SrcIdx); + end; + SrcBitsLeft := 8; + end; + { extract MSB from SrcByte } + CharVal := (CharVal shl 1) or ((SrcByte shr 7) and 1); + SrcByte := SrcByte shl 1; + Dec(SrcBitsLeft); + end; + Inc(DstIdx); + Result_[DstIdx] := Chr(UnpackFunc(CharVal)); + end; + + { check if there's a complete character remaining in the accumulator } + if SrcBitsLeft >= BitsPerChar then begin + CharVal := SrcByte shr (8 - BitsPerChar); + Inc(DstIdx); + Result_[DstIdx] := Chr(UnpackFunc(CharVal)); + end; + + Result_[0] := Chr(DstIdx); + GenericUnpack := Result_; + end; + + function Pack4BitKey(Src : string; Len : Byte) : string; + begin + Pack4BitKey := GenericPack(Src, Len, 4, TPackFunc(@Pack4Prim)); + end; + + function Pack5BitKeyUC(Src : string; Len : Byte) : string; + begin + Pack5BitKeyUC := GenericPack(Src, Len, 5, TPackFunc(@Pack5UCPrim)); + end; + + function Pack6BitKeyUC(Src : string; Len : Byte) : string; + begin + Pack6BitKeyUC := GenericPack(Src, Len, 6, TPackFunc(@Pack6UCPrim)); + end; + + function Pack6BitKey(Src : string; Len : Byte) : string; + begin + Pack6BitKey := GenericPack(Src, Len, 6, TPackFunc(@Pack6Prim)); + end; + + function Unpack4BitKey(Src : string) : string; + begin + Unpack4BitKey := GenericUnpack(Src, 4, TPackFunc(@Unpack4Prim)); + end; + + function Unpack5BitKeyUC(Src : string) : string; + begin + Unpack5BitKeyUC := GenericUnpack(Src, 5, TPackFunc(@Unpack5UCPrim)); + end; + + function Unpack6BitKeyUC(Src : string) : string; + begin + Unpack6BitKeyUC := GenericUnpack(Src, 6, TPackFunc(@Unpack6UCPrim)); + end; + + function Unpack6BitKey(Src : string) : string; + begin + Unpack6BitKey := GenericUnpack(Src, 6, TPackFunc(@Unpack6Prim)); + end; + + function DescendingKey(S : string; MaxLen : Byte) : string; + var + I : Word; + ResLen : Word; + begin + if Length(S) > MaxLen then + ResLen := Length(S) + else + ResLen := MaxLen; + for I := 1 to Length(S) do + S[I] := Chr(not Ord(S[I])); + if MaxLen > Length(S) then + FillChar(S[Succ(Length(S))], MaxLen - Length(S), $FF); + S[0] := Chr(ResLen); + DescendingKey := S; + end; + +{$ELSE} +{ TP7 implementation with OBJ linkage and inline asm } + +var + ProcPtr : Word; {!!.22} + + {$L NUMKEYS.OBJ} + + function Pack4BitKey(Src : string; Len : Byte) : string; + external; + function Pack5BitKeyUC(Src : string; Len : Byte) : string; + external; + function Pack6BitKeyUC(Src : string; Len : Byte) : string; + external; + function Pack6BitKey(Src : string; Len : Byte) : string; + external; + + function Unpack4BitKey(Src : string) : string; + external; + function Unpack5BitKeyUC(Src : string) : string; + external; + function Unpack6BitKeyUC(Src : string) : string; + external; + function Unpack6BitKey(Src : string) : string; + external; + + function DescendingKey(S : string; MaxLen : Byte) : string; + external; + + procedure ReverseBytes(var V; Size : Word); + {-Reverse the ordering of bytes from V[1] to V[Size]. Size must be >= 2.} + inline( + $8C/$DB/ {mov bx,ds ;save DS} + $59/ {pop cx ;CX = Size} + $5E/ {pop si} + $1F/ {pop ds ;DS:SI => V[1]} + $89/$F7/ {mov di,si ;DS:DI = V[Size]} + $01/$CF/ {add di,cx} + $4F/ {dec di} + $D1/$E9/ {shr cx,1} + { again:} + $8A/$04/ {mov al,[si] ;switch DS:DI} + $86/$05/ {xchg al,[di] ; and DS:DI} + $88/$04/ {mov [si],al} + $46/ {inc si ;adjust indexes} + $4F/ {dec di} + $E2/$F6/ {loop again} + $8E/$DB); {mov ds,bx ;restore DS} + + procedure ToggleBits(var V; Size : Word); {!!.04} + {-Toggle the bits from V[1] to V[Size]} {!!.04} + inline( + $59/ {pop cx ;cx = Size} + $5F/ {pop di} + $07/ {pop es ;es:di -> V} + {again:} + $26/$F6/$15/ {not byte ptr es:[di] ;flip bits} + $47/ {inc di} + $E2/$FA); {loop again} + + + function SwapWord(L : LongInt) : LongInt; + {-Swap low- and high-order words of L} + inline( + $5A/ {pop dx ;pop low word into DX} + $58); {pop ax ;pop high word into AX} + + function FirstRotation(W : Word) : Word; + {-Move sign bit from high bit of MSB of mantissa (AH) into high bit of + exponent (AL), rotating low bit of exponent into its place.} + inline( + $58/ {pop ax ;AX = W} + $80/$F4/$80/ {xor ah,$80 ;flip sign bit} + $D0/$C4/ {rol ah,1 ;rotate sign bit into CF} + $D0/$D8/ {rcr al,1 ;rotate sign bit into AL,} + { ;low bit of AL into CF} + $D0/$DC); {rcr ah,1 ;rotate low bit of AL into} + { ;high bit of AH} + + function SecondRotation(W : Word) : Word; + {-Undo the work of the first rotation} + inline( + $58/ {pop ax ;AX = W} + $34/$80/ {xor al,$80 ;flip sign bit} + $D0/$C4/ {rol ah,1 ;rotate high bit of AH into CF} + $D0/$D0/ {rcl al,1 ;rotate it back into low bit of AL} + { ;sign bit out of AL into CF} + $D0/$DC); {rcr ah,1 ;rotate sign bit back into} + { ;high bit of AH} +{$ENDIF FPC} + + procedure ZeroPad(var S : String; Len : Word); + {-Pad S to length Len with 0's} + var + SLen : Byte absolute S; + begin + if SLen < Len then begin + FillChar(S[Succ(SLen)], Len-SLen, 0); + SLen := Len; + end; + end; + + function ShortToKey(S : ShortInt) : String1; + {-Convert a shortint to a string} + begin + ShortToKey[0] := #1; + ShortToKey[1] := Char(S xor $80); + end; + + function KeyToShort(S : String1) : ShortInt; + {-Convert a string to a shortint} + begin + KeyToShort := ShortInt(S[1]) xor $80; + end; + + function ByteToKey(B : Byte) : String1; {!!.41} + {-Convert a byte to a string} + begin + ByteToKey[0] := #1; + ByteToKey[1] := Char(B); + end; + + function KeyToByte(S : String1) : Byte; {!!.41} + {-Convert a string to a byte} + begin + KeyToByte := Byte(S[1]); + end; + + function IntToKey(I : Integer) : String2; + {-Convert an integer to a string} + const + LResult : {!!.51} + record case Byte of + 0 : (Len : Byte; RI : Word); + 1 : (Str : String2); + end = (Str : ' '); + begin + LResult.RI := Swap(I xor $8000); {!!.51} + IntToKey := LResult.Str; {!!.51} + end; + + function KeyToInt(S : String2) : Integer; + {-Convert a string to an integer} + var + Temp : + record + Len : Byte; + I : Integer; + end absolute S; + begin + KeyToInt := Swap(Temp.I) xor $8000; + end; + + function WordToKey(W : Word) : String2; + {-Convert a word to a string} + const + LResult : {!!.51} + record case Byte of + 0 : (Len : Byte; RW : Word); + 1 : (Str : String2); + end = (Str : ' '); + begin + LResult.RW := Swap(W); {!!.51} + WordToKey := LResult.Str; {!!.51} + end; + + function KeyToWord(S : String2) : Word; + {-Convert a string to a word} + var + Temp : + record + Len : Byte; + W : Word; + end absolute S; + begin + KeyToWord := Swap(Temp.W); + end; + + function LongToKey(L : LongInt) : String4; + {-Convert a longint to a string} + const + LResult : {!!.51} + record case Byte of + 0 : (Len : Byte; W1, W2 : Word); + 1 : (Str : String4); + end = (Str : ' '); + var + LRec : + record + L1 : Word; + L2 : Word; + end absolute L; + begin + L := L xor $80000000; + LResult.W1 := Swap(LRec.L2); {!!.51} + LResult.W2 := Swap(LRec.L1); {!!.51} + LongToKey := LResult.Str; {!!.51} + end; + + function KeyToLong(S : String4) : LongInt; + {-Convert a string to a longint} + var + Temp : + record case Byte of + 0 : (Len : Byte; W1, W2 : Word); + 1 : (X : Byte; L : LongInt); + end absolute S; + begin + Temp.W1 := Swap(Temp.W1); + Temp.W2 := Swap(Temp.W2); + KeyToLong := SwapWord(Temp.L) xor $80000000; + end; + + function RealToKey(R : Real) : String6; + {-Convert a real to a string} + const + Temp : + record case Byte of + 0 : (Len : Byte; RR : Real); + 1 : (Str : String6); + 2 : (XXX, Exp, LSB : Byte); + 3 : (YYY : Byte; MantExp : Word); + end = (Str : ' '); + begin + Temp.RR := R; + + {put the mantissa into MSB->LSB order} + ReverseBytes(Temp.LSB, 5); + + {move the sign bit from the MSB of the mantissa into the high bit + of the exponent, rotating the low bit of the exponent into its place} + Temp.MantExp := FirstRotation(Temp.MantExp); + + if Temp.Exp and $80 = 0 then begin {!!.04} + ToggleBits(Temp.RR, 6); {!!.04} + Temp.Exp := Temp.Exp and $7F; {!!.04} + end; {!!.04} + + RealToKey := Temp.Str; + end; + + function KeyToReal(S : String6) : Real; + {-Convert a string to a real} + var + Temp : + record case Byte of + 0 : (Len : Byte; RR : Real); + 1 : (Str : String6); + 2 : (XXX, Exp, MSB : Byte); + 3 : (YYY : Byte; MantExp : Word); + end absolute S; + begin + {pad to proper length just in case} + ZeroPad(S, 6); + + if Temp.Exp and $80 = 0 then begin {!!.04} + ToggleBits(Temp.RR, 6); {!!.04} + Temp.Exp := Temp.Exp and $7F; {!!.04} + end; {!!.04} + + {put the sign bit back where it belongs} + Temp.MantExp := SecondRotation(Temp.MantExp); + + {put the mantissa back into LSB->MSB order} + ReverseBytes(Temp.MSB, 5); + + KeyToReal := Temp.RR; + end; + +type + nkBCD = array[1..10] of Byte; + + function BcdToKey(var B) : String10; + {-Convert a BCD real to a string} + const + Temp : + record case Byte of + 0 : (Len : Byte; BT : nkBCD); + 1 : (Str : String10); + 2 : (XXX, Exp, LSB : Byte); + end = (Str : ' '); + var + BP : nkBCD absolute B; + begin + {regularize 0 values} + if BP[1] and $7F = 0 then + FillChar(BP, SizeOf(BP), 0); + + Temp.BT := BP; + + {put the mantissa into MSB->LSB order} + ReverseBytes(Temp.LSB, 9); + + {flip the sign bit} + Temp.Exp := Temp.Exp xor $80; + + if Temp.Exp and $80 = 0 then begin + ToggleBits(Temp.BT, 10); + Temp.Exp := Temp.Exp and $7F; + end; + + BcdToKey := Temp.Str; + end; + + procedure KeyToBcd(S : String10; var B); + {-Convert a string to a BCD real} + var + Temp : + record case Byte of + 0 : (Len : Byte; BT : nkBCD); + 1 : (XXX, Exp, MSB : Byte); + end absolute S; + BR : nkBcd absolute B; + begin + {pad to proper length just in case} + ZeroPad(S, 10); + + {flip the sign bit} + Temp.Exp := Temp.Exp xor $80; + + if Temp.Exp and $80 <> 0 then begin + ToggleBits(Temp.BT, 10); + Temp.Exp := Temp.Exp or $80; + end; + + {put the mantissa back into LSB->MSB order} + ReverseBytes(Temp.MSB, 9); + + BR := Temp.BT; + end; + +{$IFOPT N+} + + function ExtToKey(E : Extended) : String10; + {-Convert an extended to a string} + const + Temp : + record case Byte of + 0 : (Len : Byte; EE : Extended); + 1 : (XXX, Exp : Byte); + 2 : (Str : String10); + end = (Str : ' '); + begin + Temp.EE := E; + + {move the exponent to the front and put mantissa in MSB->LSB order} + ReverseBytes(Temp.EE, 10); + + {flip the sign bit} + Temp.Exp := Temp.Exp xor $80; + + if Temp.Exp and $80 = 0 then begin {!!.04} + ToggleBits(Temp.EE, 10); {!!.04} + Temp.Exp := Temp.Exp and $7F; {!!.04} + end; {!!.04} + + ExtToKey := Temp.Str; + end; + + function KeyToExt(S : String10) : Extended; + {-Convert a string to an extended} + var + Temp : + record case Byte of + 0 : (Len : Byte; EE : Extended); + 1 : (XXX, Exp : Byte); + 2 : (Str : String10); + end absolute S; + begin + {pad to proper length just in case} + ZeroPad(S, 10); + + {flip the sign bit} + Temp.Exp := Temp.Exp xor $80; + + if Temp.Exp and $80 <> 0 then begin {!!.04} + ToggleBits(Temp.EE, 10); {!!.04} + Temp.Exp := Temp.Exp or $80; {!!.04} + end; {!!.04} + + {move the exponent back to the end and put mantissa in LSB->MSB order} + ReverseBytes(Temp.EE, 10); + + KeyToExt := Temp.EE; + end; + +{$ENDIF} + +function CStyleNumKey(S : String) : String; + {-Convert Pascal-style numkey S into a C-style numkey, compatible with ASCIIZ} +const + MaxInpStrLen = 223; +{$IFNDEF FPC} +type + PWord = ^Word; +{$ENDIF} +var +{$IFDEF FPC} + SrcOfs : Word; +{$ELSE} + WPtr : PWord; +{$ENDIF} + I, ResLen, ShiftCount, OrigLen : Word; + ResStr : String; +begin + OrigLen := Length(S); + if (OrigLen = 0) or (OrigLen > MaxInpStrLen) then begin + CStyleNumKey := ''; + Exit; + end; + + ResLen := OrigLen+Succ(Pred(OrigLen) DIV 7); + ResStr[0] := Chr(ResLen); + + S[0] := #0; +{$IFDEF FPC} + { Zero-pad byte after valid data. The loop reads one byte past + the end of the string data; in TP7 the stack garbage was always + the same value, but on 64-bit FPC it varies. } + if OrigLen < 255 then + S[OrigLen + 1] := #0; +{$ENDIF} + if OrigLen = 4 then + ShiftCount := 4 + else + ShiftCount := 1; +{$IFDEF FPC} + SrcOfs := 0; + for I := 1 To ResLen do begin + ResStr[I] := Chr(((Swap(PWord(@S[SrcOfs])^) shr ShiftCount) and $FF) or $80); + if ShiftCount < 7 then begin + Inc(ShiftCount); + Inc(SrcOfs); + end else + ShiftCount := 0; + end; +{$ELSE} + WPtr := @S; + + for I := 1 To ResLen do begin + ResStr[I] := Chr(((Swap(WPtr^) shr ShiftCount) and $FF) or $80); + if ShiftCount < 7 then begin + Inc(ShiftCount); + Inc(PWord(@WPtr)^); + end else + ShiftCount := 0; + end; +{$ENDIF} + + if OrigLen = 4 then + ResStr[1] := Chr((Byte(ResStr [1]) shl 4) or $01); + + CStyleNumKey := ResStr; +end; + +function PascalStyleNumKey(S : String) : String; + {-Convert C-style numkey S into a Pascal-style numkey} +{$IFNDEF FPC} +Type + PByte = ^Byte; + PWord = ^Word; +{$ENDIF} +Var + B1Ptr, B2Ptr : PByte; + I, ShiftLCount, ShiftRCount, ResLen, OrigLen : Word; +begin + OrigLen := Length(S); + if OrigLen = 0 then begin + PascalStyleNumKey := ''; + Exit; + end; + + ResLen := OrigLen-Succ(Pred(OrigLen) DIV 8); + S[0] := Chr(ResLen); + + B1Ptr := @S[1]; + B2Ptr := @S[2]; + if OrigLen = 5 then begin + B1Ptr^ := B1Ptr^ shr 4; + ShiftLCount := 4; + ShiftRCount := 3; + end else begin + ShiftLCount := 1; + ShiftRCount := 6; + end; + + for I := 1 To ResLen do begin + B1Ptr^ := (B1Ptr^ shl ShiftLCount) or ((B2Ptr^ and $7F) shr ShiftRCount); + if ShiftLCount < 7 then begin + Inc(ShiftLCount); + Dec(ShiftRCount); +{$IFDEF FPC} + Inc(B1Ptr); + Inc(B2Ptr); +{$ELSE} + Inc(PWord(@B1Ptr)^); + Inc(PWord(@B2Ptr)^); +{$ENDIF} + end else begin + ShiftLCount := 1; + ShiftRCount := 6; +{$IFDEF FPC} + Inc(B1Ptr, 2); + Inc(B2Ptr, 2); +{$ELSE} + Inc(PWord(@B1Ptr)^, 2); + Inc(PWord(@B2Ptr)^, 2); +{$ENDIF} + end; + end; + + PascalStyleNumKey := S; +end; + +function CStyleDescendingKey(S : string; MaxLen : byte) : string; + {-Convert S to a descending key, using C-style algorithm} +var + I : Word; + ToAdd : Integer; +begin + ToAdd := MaxLen-Length(S); + if ToAdd < 0 then begin + CStyleDescendingKey := ''; + exit; + end; + for I := 1 to Length(S) do + S[I] := Char(-Byte(S[I])); + FillChar(S[succ(Length(S))], ToAdd, $FF); + S[0] := Chr(MaxLen); + CStyleDescendingKey := S; +end; + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/nwbase.pas b/src/wc_sdk/nwbase.pas new file mode 100644 index 0000000..83751d0 --- /dev/null +++ b/src/wc_sdk/nwbase.pas @@ -0,0 +1,1381 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$B+,F-,I-,R-,S-,V-} + {$IFDEF CanAllowOverlays} + {$F+,O+,A-} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-} + {$IFDEF Ver70} + {$P-} + {$ENDIF} + {$IFDEF Ver80} + {$P-} + {$ENDIF} + {$ENDIF} + {all other compiler options are 'don't care'} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit NWBase; + {-Unit to provide base NetWare call functionality.} + +{!!.51 Notes: + - Many routines in the interface were rearranged to allow + for the unit to be initialized automatically but not in + the unit initialization block. These code movements have + NOT been flagged. + - It is a programmer error to call a NETX or VLM specific + call without first checking for the presence of NETX or + VLM. Generally it will crash the system if you attempt + to call a shell that's not present. Call nwShellType + first.} + +{-Activate the CreateRealModeStack compiler define if you wish to use + a user allocated 1K stack for simulated real mode calls instead of + the small one supplied by the DPMI server. A debug tool.} +{$IFDEF DPMIorWnd} {!!.51} +{.$DEFINE CreateRealModeStack} {!!.51} +{$ENDIF} {!!.51} + +interface + +{$IFNDEF FPC} +{$IFDEF DPMIorWnd} +uses + {$IFDEF Windows} + WinProcs, WinTypes, + {$IFDEF VER80} {!!.51} + DosSupp, {!!.51} + {$ELSE} {!!.51} + WinDos, + {$ENDIF} {!!.51} + {$ELSE} + WinAPI, + {$ENDIF} + DPMI; +{$ENDIF} +{$ENDIF} + +const + {NWXxxx NetWare units error codes} + nwErrDPMI = $7F01; {DPMI error: either out of selectors, or DOS memory} + nwErrWrongVer= $7F02; {Server NetWare version does not support call} + nwErrShell = $7F03; {Shell error: eg no shell, wrong shell for call} + nwErrMemory = $7F04; {Out of heap memory} + nwErrIntr = $7F05; {Error on an interrupt, generally DPMI based} + nwErrBadData = $7F06; {Bad data passed to routine} + nwErrTooManyConns = $7F07; {Too many connections} + nwErrNoMoreConns = $7F08; {No more connections found} + + nwErrBaseNETX = $8100; {Base error code for NETX errors: $8100-$81FF} + nwErrBaseVLM = $8800; {Base error code for VLM errors: $8800-$88FF} + nwErrBaseServer= $8900; {Base error code for server errors: $8900-$89FF} + +const + {VLM Destination ID values} + vlmVLM = $01; {VLM.EXE manager} {**} + vlmConn = $10; {CONN.VLM} {**} + vlmTransport = $20; {TRAN.VLM} {**} + vlmIPX = $21; {IPX.VLM} + vlmTCP = $22; {TCP.VLM} + vlmNWP = $30; {NWP.VLM} {**} + vlmBindery = $31; {BIND.VLM} + vlmNDS = $32; {NDS.VLM} + vlmPNW = $33; {PNW.VLM} + vlmRSA = $34; {RSA.VLM} + vlmRedir = $40; {REDIR.VLM} {**} + vlmFIO = $41; {FIO.VLM} + vlmPrint = $42; {PRINT.VLM (optional)} {**} + vlmGeneral = $43; {GENERAL.VLM} {**} + vlmNETX = $50; {NETX.VLM} + vlmAuto = $60; {AUTO.VLM} + vlmNMR = $100; {NMR.VLM} + {Those constants marked ** are used by these NetWare units} + +const + {Versions where 1000-user capabilities appear} + ServerVersion311 = $030B; {version number for NetWare 3.11} + NETXVersion330 = $031E; {version number for NETX 3.30} + +type + {Prepare for 32-bit Pascal} + nwInt = integer; {16-bit signed integer} + nwLong= longint; {32-bit signed integer} + + {Registers variable for NetWare units} + TnwRegisters = record + case byte of + 0 : (EDI, ESI, EBP, ERes, + EBX, EDX, ECX, EAX : nwLong; + Flags : Word; + ES, DS, FS, GS, IP, CS, SP, SS : Word); + 1 : (DI, EDIH, + SI, ESIH, + BP, EBPH : word; + Fill1 : nwLong; + BX, EBXH, + DX, EDXH, + CX, ECXH, + AX, EAXH : word); + 2 : (Fill2 : array [0..3] of nwLong; + BL, BH : byte; Fill3 : word; + DL, DH : byte; Fill4 : word; + CL, CH : byte; Fill5 : word; + AL, AH : byte; Fill6 : word); + end; + + {NetWare Shell types} + TnwShellType = (nsNone, {..none detected} + nsNETX, {..NETX} + nsVLM); {..VLM} + + {A server handle} + TnwServer = word; + + {A NetWare error code} + TnwErrorCode = word; + + {A bindery object name} + TnwObjectStr = string[47]; + {A bindery property name} + TnwPropStr = string[15]; + + {The date/time types used by NetWare units} + nwDayOfWeek = (nwSun, nwMon, nwTue, nwWed, nwThu, nwFri, nwSat); + TnwDate = record + Year : word; + Month : byte; + Day : byte; + Hour : byte; + Minute : byte; + Second : byte; + WeekDay : nwDayOfWeek; + end; + + {A 6 byte type for NetWare node addresses} + PhysicalNodeAddress = array[1..6] of Byte; + + {Type that defines a NetWare 3-part internet address} + IPXAddress = record + Network : nwLong; {high-low} + Node : PhysicalNodeAddress; + Socket : Word; + end; + + {A procedural type to uppercase a string} + TnwUpperStr = procedure (var S : string); + + {The server name table under NETX. Internal Use Only.} + PNETXServerNameTable = ^TNETXServerNameTable; + TNETXServerNameTable = array [1..8] of array [0..47] of char; + +type + {Buffer type for data transfer} + PRealBuffer = ^TRealBuffer; + TRealBuffer = array [0..1023] of byte; + +const + {Global buffer variables for NWXxxx units} + {Note: In pmode, the buffer is in realmode memory; nwGlobalBuf is + a pmode pointer to it and nwGlobalBufRealPtr is the realmode + pointer. + In realmode, both nwGlobalBuf and nwGlobalBufRealPtr are + the same value. + The default size is 640 bytes. + The buffer is expanded with nwGrowGlobalBuf. + The VLM calls make use of nwGlobalBufVLM, in real and Windows + modes this equals nwGlobalBuf, in pmode nwGlobalBufPtr.} + nwGlobalBuf : PRealBuffer = nil; {Pointer to global buffer} + nwGlobalBufSize: word = 0; {Current size of nwGlobalBuf} + nwGlobalBufRealPtr : PRealBuffer = nil; {Realmode pointer to nwGlobalBuf} + nwGlobalBufVLM : PRealBuffer = nil; {Pointer to global buffer for VLM calls} {!!.51} + +var + {Routine that will be used to uppercase a string. The default one + will map 'a'..'z' onto 'A'..'Z'; change it if you want other + characters to be remapped as well.} + nwUpperStr : TnwUpperStr; + +function nwShellType : TnwShellType; + {-Return the type of NetWare shell present on the workstation.} + +function nwShellVersion : word; + {-Return the version number (hibyte=major, lobyte=minor) of the shell.} + +function nwServerCall(Server : TnwServer; + Func : byte; + ReqLen : word; var Request; + RpyLen : word; var Reply) : TnwErrorCode; + {-Call NetWare server via NCP with pre-initialised request and reply + packets. Function result is error code.} + +function nwIsValidServer(Server : TnwServer) : boolean; + {-Return true if Server is a recognized server handle.} + +function nwSwapLong(L : nwLong) : nwLong; + {-Swap a NetWare longint into Intel format (and vice-versa).} + inline($5A/ {pop dx} + $86/$D6/ {xchg dh, dl} + $58/ {pop ax} + $86/$C4); {xchg ah, al} + +function nwIPXAddressStr(var Address : IPXAddress) : string; + {-Converts an IPX address into a displayable string of the form + wwwwwwww:nnnnnnnnnnnn:ssss with w..w being the hex network + number (8 chars), n..n being the hex node address (12 chars), + and s the hex socket number (4 chars), making 26 chars altogether.} + +function vlmCall(DestID : word; + DestFunc : word; + var Regs : TnwRegisters) : TnwErrorCode; + {-Internal routine to call VLM directly. Function result is error code. + It is undefined as to what would happen if the VLM manager is not + loaded. Check this first with a call to nwShellType.} + +function vlmVersion(DestID : word) : word; + {-Routine to get version number of any VLM module. Pass one of the VLM + destination ID constants, returns major version in high byte, minor + version in low byte. Returns zero if VLM module not loaded.} + +function nwGetMem(var P; Size : word) : boolean; + {-Internal routine to allocate heap memory safely, returns true for success} + +procedure nwNETXPushServer(Server : TnwServer); + {-Saves the current preferred server, sets it to Server. NETX ONLY.} + +procedure nwNETXPopServer; + {-Restores the change made by nwNETXPushServer. NETX ONLY.} + +function nwIntr(Intr : byte; var Regs : TnwRegisters) : TnwErrorCode; + {-Issue an Intr interrupt using register values in Regs.} + +function nwGrowGlobalBuf(NewSize : word) : boolean; + {-Grow the realmode buffer pointed to by nwGlobalBuf, return true if + successful.} + +procedure nwCvtStrToAsciiz(var Buffer; MaxStrLen : byte); + {-Convert Pascal string to an ASCIIZ string in situ. + Note that the buffer is assumed to be at least MaxStrLen+1 bytes long} + +procedure nwCvtAsciizToStr(var Buffer; MaxStrLen : byte); + {-Convert an ASCIIZ string to a Pascal string in situ. + Note that the buffer is assumed to be at least MaxStrLen+1 bytes long} + +function nwMinI(X, Y : nwInt) : nwInt; + inline($58/$5A/ {pop ax & dx} + $39/$D0/ {cmp ax, dx} + $7C/$01/ {jl @@exit} + $92 {xchg ax, dx} + ); {@@exit:} +function nwMaxI(X, Y : nwInt) : nwInt; + inline($58/$5A/ {pop ax & dx} + $39/$D0/ {cmp ax, dx} + $7F/$01/ {jg @@exit} + $92 {xchg ax, dx} + ); {@@exit:} + {-Routines to find min and max of nwInts} + +function nwNETXGetDriveTable(Func : word; var Table) : TnwErrorCode; + {-Internal routine. NETX ONLY.} + +function nwNETXGetServerNameTable : PNETXServerNameTable; + {-Internal routine. NETX ONLY.} + +procedure nwInitRegs(var Regs : TnwRegisters); + {-Internal routine. Sets a TnwRegisters variable to zero.} + inline($5F/$07/ {pop di, pop es} + $FC/ {cld} + $31/$C0/ {xor ax, ax} + $B9/$19/$00/ {mov cx, sizeof(TnwRegisters) div 2} + $F3/$AB); {rep stosw} + +implementation + +var + ExitSave : pointer; {Exit procedure chain} + InitCalled : boolean; {True if unit's initialisation called} + InternalShellType : TnwShellType; {Saved shell type} + InternalShellVer : word; {Saved shell version} + vlmCallAddress : pointer; {VLM realmode entry point} + PushedServer : TnwServer; {Old server handle: see nwNETXPushServer} + NETXServerNameTable : PNETXServerNameTable; + {$IFDEF Windows} {!!.52} + NWCALLSLoaded : boolean; {True if NWCALLS explicitly loaded} {!!.52} + {$ENDIF} {!!.52} + +{$IFDEF CreateRealModeStack} {!!.51 start} +const + RealModeStackSize = 1024; {do not reduce below 1K} +type + PRealModeStack = ^TRealModeStack; + TRealModeStack = array [0..pred(RealModeStackSize)] of byte; +var + RealModeStack : pointer; + RealModeStackPtr : PRealModeStack; +{$ENDIF} {!!.51 end} + +type + OS = record O, S : word; end; {to split pointer into sel/seg & ofs} + LH = record L, H : word; end; {to split nwLong into hi/lo words} + + {A VLM fragment and fragment list. Element [0] is the request buffer, + element [1] the reply buffer.} + TFragment = record + Address : pointer; + Length : word; + end; + TFragmentList = array [0..1] of TFragment; + +{$IFDEF Windows} {!!.51 start} +type + TNWCALLSRegPack = record {Register struc for nwVLMRequest} + nwSI, nsDS, nwDI, nwES, nwAX, nwBX, nwCX, nwDX : word; + end; + + TnwCallsInit = function (Pin, POut : pointer) : TnwErrorCode; + TnwVLMRequest = function (SourceID, DestID, DestFunc : word; + var Regs : TNWCALLSRegPack; + SegFlags : word) : TnwErrorCode; +var + nwCallsInit : TnwCallsInit; {entry point in NWCALLS.DLL} + nwVLMRequest : TnwVLMRequest; {entry point in NWCALLS.DLL} +{$ENDIF} {!!.51 end} + +function nwHeapError(Size : word) : integer; far; + begin + nwHeapError := 1; + end; + +function nwGetMem(var P; Size : word) : boolean; + var + Pt : pointer absolute P; + SaveHeapError : pointer; + begin + SaveHeapError := HeapError; + HeapError := @nwHeapError; + GetMem(Pt, Size); + nwGetMem := Pt <> nil; + HeapError := SaveHeapError; + end; + +{$IFDEF DPMIorWnd} +function DOSGetMem(var RealPtr, ProtPtr; Size : word) : boolean; near; + var + RealMode : pointer absolute RealPtr; + ProtMode : pointer absolute ProtPtr; + AllocResult : longint; + begin + AllocResult := GlobalDOSAlloc(Size); + if (AllocResult <> 0) then + begin + RealMode := Ptr(LH(AllocResult).H, 0); + ProtMode := Ptr(LH(AllocResult).L, 0); + DOSGetMem := true; + end + else DOSGetMem := false; + end; + +function DOSFreeMem(ProtPtr : pointer) : boolean; near; + begin + DOSFreeMem := GlobalDOSFree(OS(ProtPtr).S) = 0; + end; +{$ENDIF} + +procedure nwNETXPushServer(Server : TnwServer); assembler; + asm + {API: Get/Set Preferred Connection ID} + {get current preferred server} + mov ax, $F001 + int $21 + mov PushedServer, ax + {set preferred server to the one we want} + mov ax, $F000 + mov dl, Server.Byte[0] + int $21 + end; + +procedure nwNETXPopServer; assembler; + asm + {API: Set Preferred Connection ID} + {set preferred server back again} + mov ax, $F000 + mov dl, PushedServer.Byte[0] + int $21 + end; + +procedure GetServerNameTable; + var + i : word; + Status : word; + Regs : TnwRegisters; + begin + {API: Get File Server Name} + NETXServerNameTable := nil; + nwInitRegs(Regs); + with Regs do + begin + AX := $EF04; + if (nwIntr($21, Regs) <> 0) then + Exit; + {$IFDEF DPMIOrWnd} + if (GetSelectorForRealMem(Ptr(ES, 0), + SI+sizeof(TNETXServerNameTable), ES) <> 0) then + Exit; + {$ENDIF} + NETXServerNameTable := Ptr(ES, SI); + end; + end; + +function nwNETXGetServerNameTable : PNETXServerNameTable; + begin + nwNETXGetServerNameTable := NETXServerNameTable; + end; + +function GetNETXVersion : word; + {-Return the NETX shell version number.} + var + Regs : TnwRegisters; + begin + {API: Get Shell Version And Type} + nwInitRegs(Regs); + with Regs do + begin + AX := $EA01; + ES := OS(nwGlobalBufRealPtr).S; + DI := OS(nwGlobalBufRealPtr).O; + if (nwIntr($21, Regs) = 0) then + GetNETXVersion := BX + else GetNETXVersion := 0; + end; + end; + +function NETXLoaded : boolean; + {-Return true if NETX is loaded} + begin + InternalShellVer := GetNETXVersion; + NETXLoaded := (InternalShellVer <> 0); + end; + +procedure vlmGetCallAddress; + {-Gets the VLM entry point} + var + Regs : TnwRegisters; + begin + vlmCallAddress := nil; + nwInitRegs(Regs); + Regs.ax := $7A20; + if (nwIntr($2F, Regs) = 0) then + if (Regs.al = 0) then + vlmCallAddress := Ptr(Regs.es, Regs.bx); + end; + +function NETXValidServer(Server : TnwServer) : boolean; near; + begin + if (1 <= Server) and (Server <= 8) then + NETXValidServer := (NETXServerNameTable^[Server][0] <> #0) + else NETXValidServer := false; + end; + +function vlmValidServer(Server : TnwServer) : boolean; near; + var + Regs : TnwRegisters; + begin + nwInitRegs(Regs); + Regs.cx := Server; + vlmValidServer := (vlmCall(vlmConn, $05, Regs) = 0); + end; + +function nwIsValidServer(Server : TnwServer) : boolean; + begin + case nwShellType of {!!.51} + nsNETX : nwIsValidServer := NETXValidServer(Server); + nsVLM : nwIsValidServer := vlmValidServer(Server); + else + nwIsValidServer := false; + end;{case} + end; + +function nwIPXAddressStr(var Address : IPXAddress) : string; + function GetHexChar(B : byte; Upper : boolean) : char; near; assembler; + asm + mov al, B + cmp Upper, 0 + jne @@ExtractUpperNibble + and al, $0F + jmp @@ConvertToASCII + @@ExtractUpperNibble: + {$IFDEF G+} + shr al, 4 + {$ELSE} + shr al, 1 + shr al, 1 + shr al, 1 + shr al, 1 + {$ENDIF} + @@ConvertToASCII: + add al, '0' + cmp al, '9' + jbe @@Exit + add al, 'a' - '0' - 10 + @@Exit: + end; + var + A : array [1..12] of byte absolute Address; + i, j : integer; + S : string[26]; + begin + S[0] := #26; + j := 0; + for i := 1 to 4 do + begin + inc(j); S[j] := GetHexChar(A[i], true); + inc(j); S[j] := GetHexChar(A[i], false); + end; + S[9] := ':'; + j := 9; + for i := 5 to 10 do + begin + inc(j); S[j] := GetHexChar(A[i], true); + inc(j); S[j] := GetHexChar(A[i], false); + end; + S[22] := ':'; + j := 22; + for i := 11 to 12 do + begin + inc(j); S[j] := GetHexChar(A[i], true); + inc(j); S[j] := GetHexChar(A[i], false); + end; + nwIPXAddressStr := S; + end; + +procedure ExitNWBase; far; + {-Exit procedure} + {$IFDEF Windows} {!!.52} + var {!!.52} + H : THandle; {!!.52} + {$ENDIF} {!!.52} + begin + ExitProc := ExitSave; + if not InitCalled then {!!.51} + Exit; {!!.51} + {$IFDEF DPMIOrWnd} + if (nwGlobalBufSize <> 0) then + if not DOSFreeMem(nwGlobalBuf) then + {nothing}; + if (InternalShellType = nsNETX) then + if (FreeLDTDescriptor(OS(NETXServerNameTable).S) <> 0) then + {nothing}; + {$ELSE} + if (nwGlobalBufSize <> 0) then + FreeMem(nwGlobalBuf, nwGlobalBufSize); + {$ENDIF} + {$IFDEF CreateRealModeStack} {!!.51} + if (RealModeStackPtr <> nil) then {!!.51} + if not DOSFreeMem(RealModeStackPtr) then {!!.51} + {nothing}; {!!.51} + {$ENDIF} {!!.51} + {$IFDEF Windows} {!!.52} + if NWCALLSLoaded then {!!.52} + begin {!!.52} + H := GetModuleHandle('NWCALLS'); {!!.52} + if (H <> 0) then {!!.52} + FreeLibrary(H); {!!.52} + end; {!!.52} + {$ENDIF} {!!.52} + end; + +{$IFDEF CreateRealModeStack} {!!.51 start} +function GetRealModeStack : boolean; + begin + GetRealModeStack := false; + if not DOSGetMem(RealModeStack, RealModeStackPtr, RealModeStackSize) then + Exit; + {for debugging purposes, fill the stack with $CC} + FillChar(RealModeStackPtr^, RealModeStackSize, $CC); + GetRealModeStack := true; + end; +{$ENDIF} {!!.51 end} + +{$IFDEF Windows} {!!.51 start} +function InitNWCALLS : boolean; + var + H : THandle; + begin + InitNWCALLS := false; + H := GetModuleHandle('NETWARE'); {!!.52} + if (H = 0) then {!!.52} + Exit; {!!.52} + + H := LoadLibrary('NWCALLS.DLL'); {!!.52} + if H < 32 then {!!.52} + Exit; {!!.52} + NWCALLSLoaded := true; {!!.52} + + @nwCallsInit := GetProcAddress(H, 'NWCALLSINIT'); + if (@nwCallsInit = nil) then + Exit; + if (nwCallsInit(nil, nil) <> 0) then + Exit; + + @nwVLMRequest := GetProcAddress(H, 'NWVLMREQUEST'); + if (@nwVLMRequest = nil) then + Exit; + + InitNWCALLS := true; + end; +{$ENDIF} {!!.51 end} + +procedure InitNWBase; + {-Unit initialization routine.} + begin + InitCalled := true; {!!.51} + + InternalShellType := nsNone; + InternalShellVer := 0; + + if not nwGrowGlobalBuf(640) then + Exit; + + {$IFDEF CreateRealModeStack} {!!.51 start} + if not GetRealModeStack then + begin + if not DOSFreeMem(nwGlobalBuf) then + {nothing}; + Exit; + end; + {$ENDIF} {!!.51 end} + + {Get shell info} + {..first look for the VLM} + vlmGetCallAddress; + if (vlmCallAddress <> nil) then + begin + InternalShellType := nsVLM; + {$IFDEF Windows} {!!.51} + {in Windows: only call vlmVersion if NWCALLS is present}{!!.51} + if InitNWCALLS then {!!.51} + {$ENDIF} {!!.51} + InternalShellVer := vlmVersion(vlmVLM); + end + {..if VLM is not loaded then look for NETX} + else if NETXLoaded then + begin + InternalShellType := nsNETX; + {InternalShellVer is set within NETXLoaded} + GetServerNameTable; + if (NETXServerNameTable = nil) then + InternalShellVer := 0; + end; + + if (InternalShellVer = 0) then + InternalShellType := nsNone; + end; + +{$IFDEF DPMI} {!!.51 various versions of vlmCall moved} +function vlmCall(DestID : word; + DestFunc : word; + var Regs : TnwRegisters) : TnwErrorCode; assembler; + {-Calls VLM module DestID using subfunction DestFunc} + asm + cmp InternalShellType, nsVLM + je @@VLMisThere + mov ax, nwErrShell + jmp @@Exit + @@VLMisThere: + xor bx, bx + push bx + push DestID + push DestFunc + mov ax, 0301h + mov cx, 6 + les di, Regs + {$IFDEF CreateRealModeStack} {!!.51 start} + mov dx, RealModeStack.Word[2] + mov es:[di].TnwRegisters.&ss, dx + mov dx, RealModeStack.Word[0] + add dx, RealModeStackSize + mov es:[di].TnwRegisters.&sp, dx + {$ENDIF} {!!.51 end} + mov dx, vlmCallAddress.Word[2] + mov es:[di].TnwRegisters.&cs, dx + mov dx, vlmCallAddress.Word[0] + mov es:[di].TnwRegisters.&ip, dx + int 31h + jc @@DPMIError + mov ax, es:[di].TnwRegisters.&ax.Word[0] + jmp @@Exit + @@DPMIError: + mov ax, nwErrDPMI + @@Exit: + mov sp, bp {Deallocate pushed variables} + end; +{$ELSE}{$IFDEF MSDOS} +function vlmCall(DestID : word; + DestFunc : word; + var Regs : TnwRegisters) : TnwErrorCode; assembler; + {-Calls VLM module DestID using subfunction DestFunc} + var + vlmEntryPoint : pointer; + asm + cmp InternalShellType, nsVLM + je @@VLMisThere + mov ax, nwErrShell + jmp @@Exit + @@VLMisThere: + {Notes: the Regs.BP field and BP register are not set/restored as + the VLM shell internally uses it as a scratch register.} + mov ax, vlmCallAddress.Word[2] + mov vlmEntryPoint.Word[2], ax + mov ax, vlmCallAddress.Word[0] + mov vlmEntryPoint.Word[0], ax + push ds {save our data segment} + push bp {...and our stack frame} + xor ax, ax {push the parameters for the VLM} + push ax + push DestID + push DestFunc + + lds si, Regs {Set up the registers...} + mov ax, [si].TnwRegisters.&SI + push ax + mov ax, [si].TnwRegisters.&DS + push ax + mov di, [si].TnwRegisters.&DI + mov bx, [si].TnwRegisters.&BX + mov dx, [si].TnwRegisters.&DX + mov cx, [si].TnwRegisters.&CX + mov ax, [si].TnwRegisters.&AX + mov es, [si].TnwRegisters.&ES + pop ds + pop si + + call vlmEntryPoint {call the VLM} + + pop bp {discard returned BP & restore our stack frame} + push ax {To return the function result} + push ds {Set up the Regs variable} + pushf + push si + lds si, Regs + mov [si].TnwRegisters.&DI, di + mov [si].TnwRegisters.&BX, bx + mov [si].TnwRegisters.&DX, dx + mov [si].TnwRegisters.&CX, cx + mov [si].TnwRegisters.&AX, ax + mov [si].TnwRegisters.&ES, es + pop ax + mov [si].TnwRegisters.&SI, ax + pop ax + mov [si].TnwRegisters.&Flags, ax + pop ax + mov [si].TnwRegisters.&DS, ax + + pop ax {get VLM call result code} + pop ds {restore Pascal's DS} + @@Exit: + end; +{$ELSE} {Windows, new for !!.51} +function vlmCall(DestID : word; + DestFunc : word; + var Regs : TnwRegisters) : TnwErrorCode; assembler; + {-Calls VLM module DestID using subfunction DestFunc} + var + NWRP : TNWCALLSRegPack; + asm + cmp InternalShellType, nsVLM + je @@VLMisThere + mov ax, nwErrShell + jmp @@Exit + @@VLMisThere: + mov dx, ds {save our data segment} + xor bx, bx {zero the SegFlags value} + + lds si, Regs {get the external registers structure} + mov di, ss {get the NWCALLS registers structure} + mov es, di + lea di, NWRP + cld {forwards} + + mov ax, [si].TnwRegisters.&SI; stosw {transfer the register values} + mov ax, [si].TnwRegisters.&DS; stosw { to the NWCALLS structure} + or ax, ax + jz @@DoneDS + or bl, 1 + @@DoneDS: + mov ax, [si].TnwRegisters.&DI; stosw + mov ax, [si].TnwRegisters.&ES; stosw + or ax, ax + jz @@DoneES + or bl, 2 + @@DoneES: + mov ax, [si].TnwRegisters.&AX; stosw + mov ax, [si].TnwRegisters.&BX; stosw + mov ax, [si].TnwRegisters.&CX; stosw + mov ax, [si].TnwRegisters.&DX; stosw + + mov ds, dx {get back our data segment} + + xor ax, ax {call the NWCALLS DLL entry point} + push ax + push DestID + push DestFunc + push ss + lea ax, NWRP + push ax + push bx + call nwVLMRequest + + mov dx, ds {save our data segment} + xchg ax, bx {save the VLM return value in BX} + + mov si, ss {get the NWCALLS registers structure} + mov ds, si + lea si, NWRP + les di, Regs {get the external registers structure} + cld + + lodsw; mov es:[di].TnwRegisters.&SI, ax {transfer the register values} + lodsw; mov es:[di].TnwRegisters.&DS, ax { from the NWCALLS structure} + lodsw; mov es:[di].TnwRegisters.&DI, ax + lodsw; mov es:[di].TnwRegisters.&ES, ax + lodsw; mov es:[di].TnwRegisters.&AX, ax + lodsw; mov es:[di].TnwRegisters.&BX, ax + lodsw; mov es:[di].TnwRegisters.&CX, ax + lodsw; mov es:[di].TnwRegisters.&DX, ax + + xchg ax, bx {get back the return value} + mov ds, dx {get back our data segment} + @@Exit: + end; +{$ENDIF}{$ENDIF} + + +{$IFDEF DPMIorWnd} +function nwGrowGlobalBuf(NewSize : word) : boolean; + {-Grow the realmode buffer, if required} + begin + if (NewSize <= nwGlobalBufSize) then + nwGrowGlobalBuf := true + else + begin + if (nwGlobalBufSize <> 0) then + if not DOSFreeMem(nwGlobalBuf) then + {nothing}; + {round up new size to nearest 128 bytes} + nwGlobalBufSize := (NewSize + 127) and $FF80; + if DOSGetMem(nwGlobalBufRealPtr, nwGlobalBuf, nwGlobalBufSize) then + begin {!!.51} + nwGrowGlobalBuf := true; {!!.51} + {$IFDEF Windows} {!!.51} + nwGlobalBufVLM := nwGlobalBuf; {!!.51} + {$ELSE} {!!.51} + nwGlobalBufVLM := nwGlobalBufRealPtr; {!!.51} + {$ENDIF} {!!.51} + end {!!.51} + else + begin + nwGrowGlobalBuf := false; + nwGlobalBufRealPtr := nil; + nwGlobalBuf := nil; + nwGlobalBufSize := 0; + nwGlobalBufVLM := nil; {!!.51} + end; + end; + end; + +function nwServerCall(Server : TnwServer; + Func : byte; + ReqLen : word; var Request; + RpyLen : word; var Reply) : TnwErrorCode; + const + VLMLeeway = $20; {ample leeway for the extra VLM memory requirements} + var + TotalSize : word; + Status : word; + Fragment : TFragmentList; + Regs : TnwRegisters; + SavedConn : byte; + begin + if (nwShellType = nsNone) then {!!.51} + begin + nwServerCall := nwErrShell; + Exit; + end; + {call the NetWare server either via NETX or VLM, using NCP} + if (InternalShellType = nsNETX) then + begin + if not NETXValidServer(Server) then + begin + nwServerCall := nwErrBaseNETX + $01; + Exit; + end; + {calculate the size of the request and reply packets} {!!.51} + TotalSize := ReqLen + RpyLen; {!!.51} + {if this is greater than our realmode buffer, grow it} {!!.51} + if not nwGrowGlobalBuf(TotalSize) then {!!.51} + begin {!!.51} + nwServerCall := nwErrDPMI; {!!.51} + Exit; {!!.51} + end; {!!.51} + {move the request buffer over to real mode} {!!.51} + Move(Request, nwGlobalBuf^[0], ReqLen); {!!.51} + {push current server handle} {!!.51} + nwNETXPushServer(Server); + {Set up the registers and call the server via NETX} + nwInitRegs(Regs); + with Regs do + begin + ax := $F200 + Func; {NCP call} + cx := ReqLen; + dx := RpyLen; + ds := OS(nwGlobalBufRealPtr).S; {point ds:si at the request buffer} + si := OS(nwGlobalBufRealPtr).O; + es := ds; {point es:di at the reply buffer} + di := si + ReqLen; + Status := nwIntr($21, Regs); + if (Status = 0) then + if (al <> 0) then + Status := nwErrBaseServer + al; + nwServerCall := Status; + end; + nwNETXPopServer; + {move the reply buffer back to the user's buffer} {!!.51} + if (RpyLen <> 0) then {!!.51} + Move(nwGlobalBuf^[ReqLen], Reply, RpyLen); {!!.51} + end + else {we're using VLM} + begin + {Note: for a pmode target we must fiddle around with realmode pointers, + copy the request buffer to realmode before making the call, and + the reply buffer from realmode afterwards. For a Windows target + the NetWare DLLs do that for us, so we can just pass the + protected mode pointers.} + if not vlmValidServer(Server) then + begin + nwServerCall := nwErrBaseVLM + $01; + Exit; + end; + {API: _TRAN Request Reply} + {$IFDEF Windows} {!!.51} + {Set up the fragments in pmode, we use 1 fragment/buffer} {!!.51} + Fragment[0].Address := @Request; {!!.51} + Fragment[0].Length := ReqLen; {!!.51} + Fragment[1].Address := @Reply; {!!.51} + Fragment[1].Length := RpyLen; {!!.51} + {Set up the registers and call the server via the VLM} {!!.51} + nwInitRegs(Regs); {!!.51} + with Regs do {!!.51} + begin {!!.51} + al := Func; {!!.51} + bl := 1; {one fragment for the request buffer} {!!.51} + if (RpyLen <> 0) then {!!.51} + dl := 1; {...one fragment for the reply buffer} {!!.51} + cx := Server; {!!.51} + ds := Seg(Fragment); {point ds:si at the request fragment} + si := Ofs(Fragment[0]); {!!.51} + es := ds; {point es:di at the reply fragment} + di := Ofs(Fragment[1]); {!!.51} + nwServerCall := vlmCall(vlmTransport, $06, Regs); {!!.51} + end; {!!.51} + {$ELSE} {DPMI} {!!.51} + {calculate the size of the request and reply packets} {!!.51} + TotalSize := ReqLen + RpyLen + VLMLeeway; {!!.51} + {if this is greater than our realmode buffer, grow it} {!!.51} + if not nwGrowGlobalBuf(TotalSize) then {!!.51} + begin {!!.51} + nwServerCall := nwErrDPMI; {!!.51} + Exit; {!!.51} + end; {!!.51} + {move the request buffer over to real mode} {!!.51} + Move(Request, nwGlobalBuf^[0], ReqLen); {!!.51} + {Set up the fragments in realmode, we use 1 fragment/buffer} + Fragment[0].Address := nwGlobalBufRealPtr; + Fragment[0].Length := ReqLen; + Fragment[1].Address := Ptr(OS(nwGlobalBufRealPtr).S, + OS(nwGlobalBufRealPtr).O + ReqLen); + Fragment[1].Length := RpyLen; + Move(Fragment, nwGlobalBuf^[ReqLen+RpyLen], sizeof(Fragment)); + {Set up the registers and call the server via the VLM} + nwInitRegs(Regs); + with Regs do + begin + al := Func; + bl := 1; {one fragment for the request buffer} + if (RpyLen <> 0) then + dl := 1; {...one fragment for the reply buffer} + cx := Server; + ds := OS(nwGlobalBufRealPtr).S; {point ds:si at the request fragment} + si := OS(nwGlobalBufRealPtr).O + ReqLen+RpyLen; + es := ds; {point es:di at the reply fragment} + di := si + sizeof(Fragment[0]); + nwServerCall := vlmCall(vlmTransport, $06, Regs); + end; + {move the reply buffer back to the user's buffer} {!!.51} + if (RpyLen <> 0) then {!!.51} + Move(nwGlobalBuf^[ReqLen], Reply, RpyLen); {!!.51} + {$ENDIF} {!!.51} + end; + end; +{$ELSE} {it's a realmode target} +function nwGrowGlobalBuf(NewSize : word) : boolean; + {-Grow the realmode buffer, if required} + begin + nwGrowGlobalBuf := true; + if (NewSize > nwGlobalBufSize) then + begin + if (nwGlobalBufSize <> 0) then + FreeMem(nwGlobalBuf, nwGlobalBufSize); + {round up new size to nearest 128 bytes} + nwGlobalBufSize := (NewSize + 127) and $FF80; + if not nwGetMem(nwGlobalBuf, nwGlobalBufSize) then + begin + nwGrowGlobalBuf := false; + nwGlobalBufSize := 0; + end; + nwGlobalBufRealPtr := nwGlobalBuf; + nwGlobalBufVLM := nwGlobalBuf; {!!.51} + end; + end; + +function nwServerCall(Server : TnwServer; + Func : byte; + ReqLen : word; var Request; + RpyLen : word; var Reply) : TnwErrorCode; + var + Status : word; + Regs : TnwRegisters; + Fragment : TFragmentList; + begin + case nwShellType of {!!.51} + nsNone : + nwServerCall := nwErrShell; + nsNETX : + begin + if not NETXValidServer(Server) then + begin + nwServerCall := nwErrBaseNETX + $01; + Exit; + end; + nwNETXPushServer(Server); + nwInitRegs(Regs); + with Regs do + begin + ax := $F200 + Func; {NCP call} + cx := ReqLen; + dx := RpyLen; + ds := seg(Request); + si := ofs(Request); + es := seg(Reply); + di := ofs(Reply); + Status := nwIntr($21, Regs); + if (al = 0) then + nwServerCall := 0 + else nwServerCall := nwErrBaseServer + al; + end; + nwNETXPopServer; + end; + nsVLM : + begin + if not vlmValidServer(Server) then + begin + nwServerCall := nwErrBaseVLM + $01; + Exit; + end; + {API: _TRAN Request Reply} + {Set up the fragments in realmode, we use 1 fragment/buffer} + Fragment[0].Address := @Request; + Fragment[0].Length := ReqLen; + Fragment[1].Address := @Reply; + Fragment[1].Length := RpyLen; + {Set up the registers and call the VLM} + nwInitRegs(Regs); + with Regs do + begin + al := Func; + bl := 1; {one fragment for the request buffer} + if (RpyLen <> 0) then + dl := 1; {...one fragment for the reply buffer} + cx := Server; + ds := Seg(Fragment[0]); {point ds:si at the request packet} + si := Ofs(Fragment[0]); + es := Seg(Fragment[1]); {point es:di at the reply fragment} + di := Ofs(Fragment[1]); + nwServerCall := vlmCall(vlmTransport, $06, Regs); + end; + end; + end;{case} + end; +{$ENDIF} + +procedure nwCvtStrToAsciiz(var Buffer; MaxStrLen : byte); +assembler; + asm + mov dx, ds {save Pascal's DS} + xor ax, ax {zero ax} + mov cx, ax {zero cx, the counter} + mov cl, MaxStrLen {get maximum string length} + lds si, Buffer {get the buffer} + mov al, [si] {get the string length byte} + cmp ax, cx {is it less than the max string length?} + jae @@LengthIsOk {no, so number of chars to move is OK} + xchg ax, cx {set num of chars to move to the string length} + @@LengthIsOk: + jcxz @@Exit {anything to do? No? Exit if so} + mov di, si {set source and dest offsets for move} + inc si + mov bx, ds {set up for move string} + mov es, bx + cld {forwards!} + rep movsb {move characters} + mov es:[di], cl {set string null terminator} + @@Exit: + mov ds, dx {restore Pascal's DS} + end; + +procedure nwCvtAsciizToStr(var Buffer; MaxStrLen : byte); +assembler; + asm + mov dx, ds {save Pascal's DS} + xor ax, ax {zero ax, ah is string length, al is null byte} + mov cx, ax {zero cx, the counter} + mov cl, MaxStrLen {get maximum string length} + add ah, cl {save max string length} + jz @@Exit {nothing to do if it's zero} + les di, Buffer {get the buffer} + cld {forwards!} + repne scasb {scan for terminating zero byte} + jne @@NoNull {none found} + inc cx {calc length of string} + sub ah, cl + jz @@Exit {if zero, nothing to do} + dec di {dest: point to zero byte} + @@NoNull: + mov si, di {source: point to last char of string} + dec si + mov bx, es {set up for move string} + mov ds, bx + std {backwards!} + mov cl, ah {set number of chars to move} + rep movsb {move characters} + mov al, ah {set string length byte} + stosb + cld {be kind to others} + @@Exit: + mov ds, dx {restore Pascal's DS} + end; + +{$IFDEF DPMIorWnd} +function nwIntr(Intr : byte; var Regs : TnwRegisters) : TnwErrorCode; +assembler; + asm + cmp InitCalled, 1 {!!.51} + je @@InitWasCalled {!!.51} + call InitNWBase {!!.51} + @@InitWasCalled: {!!.51} + mov ax, $0300 {set up for DPMI simulate realmode} + xor cx, cx { interrupt} + mov bx, cx + mov bl, Intr + les di, Regs + {$IFDEF CreateRealModeStack} {!!.51 start} + mov dx, RealModeStack.Word[2] + mov es:[di].TnwRegisters.&ss, dx + mov dx, RealModeStack.Word[0] + add dx, RealModeStackSize + mov es:[di].TnwRegisters.&sp, dx + {$ENDIF} {!!.51 end} + int $31 + jc @@Error {was there a DPMI error?} + xor ax, ax {No, so return zero error} + jmp @@Exit + @@Error: + mov ax, nwErrIntr {Yes, return DPMI error code} + @@Exit: + end; +{$ELSE} +function nwIntr(Intr : byte; var Regs : TnwRegisters) : TnwErrorCode; +assembler; + asm + cmp InitCalled, 1 {!!.51} + je @@InitWasCalled {!!.51} + call InitNWBase {!!.51} + @@InitWasCalled: {!!.51} + push ds {save Pascal's DS} + lea di, @@IntrCall {patch the interrupt number} {!!.51} + mov al, Intr + mov cs:[di+1], al {!!.51} + + lds si, Regs {set up the registers from the} + mov ax, [si].TnwRegisters.&SI { TnwRegisters structure} + push ax + mov ax, [si].TnwRegisters.&DS + push ax + mov di, [si].TnwRegisters.&DI + mov bp, [si].TnwRegisters.&BP + mov bx, [si].TnwRegisters.&BX + mov dx, [si].TnwRegisters.&DX + mov cx, [si].TnwRegisters.&CX + mov ax, [si].TnwRegisters.&AX + mov es, [si].TnwRegisters.&ES + pop ds + pop si + + @@IntrCall: {!!.51} + int 0 {do the interrupt} {!!.51} + + push ds {get ready for setting the} + pushf { TnwRegisters structure} + push bp + push si + mov bp, sp {restore our stack frame} + add bp, 10 + lds si, Regs {set up the TnwRegisters structure} + mov [si].TnwRegisters.&DI, di + mov [si].TnwRegisters.&BX, bx + mov [si].TnwRegisters.&DX, dx + mov [si].TnwRegisters.&CX, cx + mov [si].TnwRegisters.&AX, ax + mov [si].TnwRegisters.&ES, es + pop ax + mov [si].TnwRegisters.&SI, ax + pop ax + mov [si].TnwRegisters.&BP, ax + pop ax + mov [si].TnwRegisters.&Flags, ax + pop ax + mov [si].TnwRegisters.&DS, ax + + pop ds {restore Pascal's DS} + xor ax, ax {return zero error} + end; +{$ENDIF} + +function nwNETXGetDriveTable(Func : word; var Table) : TnwErrorCode; + {-Return one of the 3 drive tables. NETX ONLY. + Func = $EF00 - Get Drive Handle Table + $EF01 - Get Drive Flag Table + $EF02 - Get Drive Connection ID} + var + Status : word; + Regs : TnwRegisters; + P : pointer; + begin + {Note: the drive tables are all 32 bytes long} + nwInitRegs(Regs); + Regs.ax := Func; + Status := nwIntr($21, Regs); + if (Status = 0) then + with Regs do + begin + {$IFDEF DPMIorWnd} + if (GetSelectorForRealMem(Ptr(ES, 0), SI+32, ES) <> 0) then + begin + nwNETXGetDriveTable := nwErrDPMI; + Exit; + end; + {$ENDIF} + P := Ptr(ES, SI); + Move(P^, Table, 32); + {$IFDEF DPMIorWnd} + if (FreeLDTDescriptor(ES) <> 0) then + {nothing}; + {$ENDIF} + end; + nwNETXGetDriveTable := Status; + end; + +procedure DefUpperStr(var S : string); far; assembler; + {-Default routine to convert a string to uppercase in situ.} + asm + mov dx, ds {save Pascal's DS} + lds si, S {get string} + xor cx, cx {calc number of chars to uppercase} + mov cl, [si] + inc cx {for first time through} + @@NextChar: + dec cx {any more characters left?} + jz @@Exit {no - exit} + inc si {get next char into AL} + mov al, [si] + cmp al, 'a' {is next char less than 'a'?} + jb @@NextChar {yes - go get next char} + cmp al, 'z' {is next char greater than 'z'?} + ja @@NextChar {yes - go get next char} + sub al, 'a' - 'A' {convert char to uppercase} + mov [si], al {store in string} + jmp @@NextChar {go get next char} + @@Exit: + mov ds, dx {restore Pascal's DS} + end; + +function vlmVersion(DestID : word) : word; + {-Return the version of VLM module DestID.} + var + Regs : TnwRegisters; + begin + vlmVersion := 0; {!!.51} + if (nwShellType = nsVLM) then {!!.51} + begin {!!.51} + {API: _Get VLM Version} + nwInitRegs(Regs); + if (vlmCall(DestID, $01, Regs) = 0) then + vlmVersion := (Regs.BX * $100) + Regs.CX; + end; {!!.51} + end; + +function nwShellType : TnwShellType; + begin + if not InitCalled then {!!.51} + InitNWBase; {!!.51} + nwShellType := InternalShellType; + end; + +function nwShellVersion : word; + begin + if not InitCalled then {!!.51} + InitNWBase; {!!.51} + nwShellVersion := InternalShellVer; + end; + +begin + nwUpperStr := DefUpperStr; {!!.51} + InitCalled := false; {!!.51} + {$IFDEF CreateRealModeStack} {!!.51} + RealModeStackPtr := nil; {!!.51} + {$ENDIF} {!!.51} + ExitSave := ExitProc; {!!.51} + ExitProc := @ExitNWBase; {!!.51} + {$IFDEF Windows} {!!.52} + NWCALLSLoaded := false; {!!.52} + {$ENDIF} {!!.52} +end. diff --git a/src/wc_sdk/nwbind.pas b/src/wc_sdk/nwbind.pas new file mode 100644 index 0000000..ac1ccd9 --- /dev/null +++ b/src/wc_sdk/nwbind.pas @@ -0,0 +1,928 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--- + Note: in tests we have discovered that the bindery emulation + provided by Directory Services on NetWare 4.x is NOT perfect. + We have discovered for example that ScanProperty will report + a property as being a set, but ReadPropertyValue will insist + that it's an item; also it has been known for ScanProperty to + say that a property has a value but no segments can be found. + Caveat programmer. + ---} + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$B+,F-,I-,R-,S-,V-} + {$IFDEF CanAllowOverlays} + {$F+,O+,A-} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-,P-} + {$ENDIF} + {all other compiler options are 'don't care'} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit NWBind; + {-Unit to provide access to the NetWare bindery.} + +interface + +uses + NWBase; + +const + {Object and Property Security Flags} + nwbAnyOne = $00; {access allowed to all clients} + nwbLogged = $01; {access allowed to logged in clients} + nwbObject = $02; {access allowed to the object itself} + nwbSupervisor = $03; {access allowed to the supervisor} + nwbNetWare = $04; {access allowed only to the NetWare operating system} + + {Bindery object types} + nwboUnknown = $0000; + nwboUser = $0001; + nwboGroup = $0002; + nwboPrintQueue = $0003; + nwboFileServer = $0004; + nwboJobServer = $0005; + nwboGateway = $0006; + nwboPrintServer = $0007; + nwboArchiveQueue = $0008; + nwboArchiveServer = $0009; + nwboJobQueue = $000A; + nwboAdministration = $000B; + nwboNASSNAGateway = $0021; + nwboRemoteBridge = $0026; + nwboRemBridgeServer = $0027; + nwboTimeSyncServer = $002D; + nwboArchiveServerSAP = $002E; + nwboAdvertisingPrint = $0047; + nwboBtrieveVAP = $0050; + nwboPrintQueueUser = $0051; + nwboWild = $FFFF; + + {Error codes} + nwbErrServerOutOfMem = $8996; {server out of memory} + nwbErrMemberExists = $89E9; {object already exists as member in set} + nwbErrNotMember = $89EA; {object does not exist as memebr in set} + nwbErrNotSetProperty = $89EB; {property is not a set} + nwbErrNoSuchSegment = $89EC; {segment number does not exist} + nwbErrPropExists = $89ED; {property already exists} + nwbErrObjExists = $89EE; {object already exists} + nwbErrInvName = $89EF; {name contains invalid characters} + nwbErrWildcardBanned = $89F0; {no wildcards allowed for this call} + nwbErrInvSecurity = $89F1; {invalid bindery security} + nwbErrNoObjRenamePriv = $89F3; {user has no object rename privileges} + nwbErrNoObjDeletePriv = $89F4; {user has no object delete privileges} + nwbErrNoObjCreatePriv = $89F5; {user has no object create privileges} + nwbErrNoPropDeletePriv = $89F6; {user has no property delete privileges} + nwbErrNoPropCreatePriv = $89F7; {user has no property create privileges} + nwbErrNoPropWritePriv = $89F8; {user has no property write privileges} + nwbErrNoPropReadPriv = $89F9; {user has no property read privileges} + nwbErrNoSuchProperty = $89FB; {given property does not exist} + nwbErrNoSuchObject = $89FC; {given object does not exist} + nwbErrBinderyLocked = $89FE; {the bindery is locked} + nwbErrBinderyFailure = $89FF; {the bindery has failed} + +type + {Bindery property value} + TnwPropValue = record + case boolean of + True : (pvItem : array [1..128] of char); + False : (pvSet : array [1..32] of nwLong); + end; + + {Bindery object password string} + TnwPasswordStr = string[127]; + +const + {Some well-known property names} + nwbLogInControlSt = 'LOGIN_CONTROL'; + nwbAccountServersSt = 'ACCOUNT_SERVERS'; + nwbAccountBalanceSt = 'ACCOUNT_BALANCE'; + nwbPasswordSt = 'PASSWORD'; + nwbSecurityEqualsSt = 'SECURITY_EQUALS'; + nwbGroupMembersSt = 'GROUP_MEMBERS'; + nwbGroupsImInSt = 'GROUPS_I''M_IN'; + nwbNetAddressSt = 'NET_ADDRESS'; + nwbIdentificationSt = 'IDENTIFICATION'; + nwbOperatorsSt = 'OPERATORS'; + +function nwbAddObjectToSet(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr; + MemberObjType : word; + MemberObjName : TnwObjectStr) : TnwErrorCode; + {-Add a bindery object to a property of type set} + +function nwbChangePassword(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + OldPassword, + NewPassword : TnwPasswordStr) : TnwErrorCode; + {-Change the password of a bindery object. + Notes: This routine does not support NetWare's encrypted + passwords.} + +function nwbChangeObjectSecurity(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + NewSecurity : byte) : TnwErrorCode; + {-Change the read/write security of a bindery object} + +function nwbChangePropertySecurity(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr; + NewPropSecurity : byte) : TnwErrorCode; + {-Change the read/write security of a bindery object's property} + +function nwbCloseBindery(Server : TnwServer) : TnwErrorCode; + {-Close the bindery + Note: ONLY use this routine for backing up the bindery files. + Whilst closed most NetWare functionality is disabled. This + function is ignored under the bindery emulation in NetWare 4.x.} + +function nwbCreateObject(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + ObjIsDynamic : boolean; + ObjSecurity : byte) : TnwErrorCode; + {-Create a new bindery object} + +function nwbCreateProperty(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName : TnwPropStr; + PropIsDynamic, + PropIsSet : boolean; + PropSecurity : byte) : TnwErrorCode; + {-Create a new property for a bindery object} + +function nwbDeleteObject(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr) : TnwErrorCode; + {-Delete a bindery object} + +function nwbDeleteObjectFromSet(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr; + MemberObjType : word; + MemberObjName : TnwObjectStr) : TnwErrorCode; + {-Delete a bindery object from a property of type set} + +function nwbDeleteProperty(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr) : TnwErrorCode; + {-Delete a property from a bindery object} + +function nwbGetBinderyAccessLevel(Server : TnwServer; + var AccessLevel : byte; + var ObjID : nwLong) : TnwErrorCode; + {-Return the workstation's access level to the bindery + Notes: the AccessLevel returned is a standard security byte: the + high nibble value is the user's write privileges, the low nibble + value is the read privileges. The ObjID returned is the logged + on user's bindery object ID.} + +function nwbGetObjectID(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + var ObjID : nwLong) : TnwErrorCode; + {-Return the bindery object's ID given its name and type} + +function nwbGetObjectName(Server : TnwServer; + ObjID : nwLong; + var ObjType : word; + var ObjName : TnwObjectStr) : TnwErrorCode; + {-Return the bindery object's name and type given its ID} + +function nwbIsObjectInSet(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr; + MemberObjType : word; + MemberObjName : TnwObjectStr) : TnwErrorCode; + {-Determine if a bindery object is in a property of type set. + Notes: if the function result is 0 the object exists in the set, + if $89EA (nwbErrNotMember) the object is not a member of the set, + otherwise some other error occurred.} + +function nwbOpenBindery(Server : TnwServer) : TnwErrorCode; + {-Open the bindery that was closed with CloseBindery} + +function nwbReadPropertyValue(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr; + SegmentNumber: byte; + var PropValue : TnwPropValue; + var PropIsDynamic: boolean; + var PropIsSet : boolean; + var MoreSegments : boolean) : TnwErrorCode; + {-Return the value of a bindery object's property. + Notes: a property consists of 1 or more 128-byte segments; the + first segment is segment 1. To read all the segments, continue + calling this routine, starting at SegmentNumber = 1, incrementing + it for each call until MoreSegments is false.} + +function nwbRenameObject(Server : TnwServer; + ObjType : word; + OldObjName, + NewObjName : TnwObjectStr) : TnwErrorCode; + {-Rename a bindery object. + Notes: must be the Supervisor or equivalent to use this call.} + +function nwbScanObject(Server : TnwServer; + var ObjType : word; + var ObjName : TnwObjectStr; + var ObjID : nwLong; + var ObjIsDynamic : boolean; + var ObjSecurity : byte; + var HasProperties : boolean) : TnwErrorCode; + {-Scan the bindery for an object. + Notes: this routine allows an application to iteratively scan the + bindery for a sequence of objects. Before making the first call + ObjID must be set to -1. For the next and subsequent calls the + ObjID must be set to the object ID that the previous call + returned. Before making any call, ObjType must be set to the + object type required (or nwboWild for any object type), and + ObjName must be set to the actual name required or a string with + a '*' wildcard character (eg 'N*' for objects whose name starts + with 'N'). (Note that to scan for a single object for which you + know the ID, Name and Type, you must still set ObjID to -1.) + The returned ObjSecurity is a standard security byte: the high + nibble value is the user's write privileges, the low nibble value + is the read privileges.} + +function nwbScanProperty(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + var Sequence : nwLong; + var PropName : TnwPropStr; + var PropIsDynamic: boolean; + var PropIsSet : boolean; + var PropSecurity : byte; + var HasValue : boolean; + var MoreProps: boolean) : TnwErrorCode; + {-Scan the bindery for an object's properties. + Notes: this routine allows an application to iteratively scan the + bindery for the properties associated with a bindery object. + Before making the first call Sequence must be set to -1. For the + next and subsequent calls Sequence must be set to the value that + the previous call returned. MoreProps is set false when the + ScanProperty routine has scanned the last property. Before making + any call, ObjType must be set to the object type and ObjName to the + actual name required (no wildcards are allowed). The returned + PropSecurity is a standard security byte: the high nibble value is + the user's write privileges, the low nibble value is the read + privileges. + WARNING: under NetWare 4.x the PropIsDynamic and PropIsSet + booleans do not seem to be returned properly by the bindery + emulation - the ReadPropertyValue routine however does give the + correct values.} + +function nwbVerifyPassword(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + Password: TnwPasswordStr) : TnwErrorCode; + {-Verify the password of a bindery object. + Notes: This routine does not support NetWare's encrypted + passwords.} + +function nwbWritePropertyValue(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr; + SegmentNumber : byte; + var PropValue : TnwPropValue; + EraseRemainingSegments : boolean) : TnwErrorCode; + {-Write a value to a property of a bindery object. + Notes: To write a value to a property you must split it first + into 128-byte segments and then write the segments in sequential + order starting at 1. For writing the final segment, ensure that + the parameter EraseRemainingSegments is set to true. Once the + segments have all been created, you may update them in any + order. This call must not be used for writing a property of type + set, for that you iteratively call AddObjectToSet.} + +implementation + +type + PReqBuffer = ^TReqBuffer; { A NetWare bindery request buffer } + TReqBuffer = record + Size : word; + Data : array [0..509] of byte; + end; + +procedure nwbPackByte(var Buffer : TReqBuffer; B : byte); near; + begin + with Buffer do + begin + Data[Size] := B; + inc(Size); + end; + end; + +procedure nwbPackWord(var Buffer : TReqBuffer; W : word); near; + var + W_asBytes : array [0..1] of byte absolute W; + begin + with Buffer do + begin + Data[Size] := W_asBytes[1]; + Data[Size+1] := W_asBytes[0]; + inc(Size, 2); + end; + end; + +procedure nwbPackLong(var Buffer : TReqBuffer; L : nwLong); near; + begin + with Buffer do + begin + Move(L, Data[Size], 4); + inc(Size, 4); + end; + end; + +procedure nwbPackString(var Buffer : TReqBuffer; var S : string); near; + begin + with Buffer do + begin + Move(S, Data[Size], succ(length(S))); + inc(Size, succ(length(S))); + end; + end; + +function nwbAddObjectToSet(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr; + MemberObjType : word; + MemberObjName : TnwObjectStr) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + nwUpperStr(PropName); + nwUpperStr(MemberObjName); + {API: Add Object To Set} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $41); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbPackString(Request, PropName); + nwbPackWord(Request, MemberObjType); + nwbPackString(Request, MemberObjName); + nwbAddObjectToSet := nwServerCall(Server, $17, Request.Size+2, Request, + 0, Dummy); + end; + +function nwbChangePassword(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + OldPassword, + NewPassword : TnwPasswordStr) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + {API: Change Bindery Object Password} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $40); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbPackString(Request, OldPassword); + nwbPackString(Request, NewPassword); + nwbChangePassword := nwServerCall(Server, $17, Request.Size+2, Request, + 0, Dummy); + end; + +function nwbChangeObjectSecurity(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + NewSecurity : byte) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + {API: Change Bindery Object Security} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $38); + nwbPackByte(Request, NewSecurity); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbChangeObjectSecurity := nwServerCall(Server, $17, + Request.Size+2, Request, + 0, Dummy); + end; + +function nwbChangePropertySecurity(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr; + NewPropSecurity : byte) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + nwUpperStr(PropName); + {API: Change Property Security} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $3B); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbPackByte(Request, NewPropSecurity); + nwbPackString(Request, PropName); + nwbChangePropertySecurity := nwServerCall(Server, $17, + Request.Size+2, Request, + 0, Dummy); + end; + +function nwbCloseBindery(Server : TnwServer) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + {API: Close Bindery} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $44); + nwbCloseBindery := nwServerCall(Server, $17, Request.Size+2, Request, + 0, Dummy); + end; + +function nwbCreateObject(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + ObjIsDynamic : boolean; + ObjSecurity : byte) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + {API: Create Bindery Object} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $32); + nwbPackByte(Request, byte(ObjIsDynamic)); + nwbPackByte(Request, ObjSecurity); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbCreateObject := nwServerCall(Server, $17, Request.Size+2, Request, + 0, Dummy); + end; + +function nwbCreateProperty(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName : TnwPropStr; + PropIsDynamic, + PropIsSet : boolean; + PropSecurity : byte) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + nwUpperStr(PropName); + {API: Create Property} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $39); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbPackByte(Request, (byte(PropIsSet) shl 1) + byte(PropIsDynamic)); + nwbPackByte(Request, PropSecurity); + nwbPackString(Request, PropName); + nwbCreateProperty := nwServerCall(Server, $17, Request.Size+2, Request, + 0, Dummy); + end; + +function nwbDeleteObject(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + {API: Delete Bindery Object} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $33); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbDeleteObject := nwServerCall(Server, $17, Request.Size+2, Request, + 0, Dummy); + end; + +function nwbDeleteObjectFromSet(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr; + MemberObjType : word; + MemberObjName : TnwObjectStr) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + nwUpperStr(PropName); + nwUpperStr(MemberObjName); + {API: Delete Bindery Object From Set} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $42); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbPackString(Request, PropName); + nwbPackWord(Request, MemberObjType); + nwbPackString(Request, MemberObjName); + nwbDeleteObjectFromSet := nwServerCall(Server, $17, + Request.Size+2, Request, + 0, Dummy); + end; + +function nwbDeleteProperty(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + nwUpperStr(PropName); + {API: Delete Property} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $3A); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbPackString(Request, PropName); + nwbDeleteProperty := nwServerCall(Server, $17, Request.Size+2, Request, + 0, Dummy); + end; + +function nwbGetBinderyAccessLevel(Server : TnwServer; + var AccessLevel : byte; + var ObjID : nwLong) : TnwErrorCode; + var + Status : word; + Request : TReqBuffer; + Reply : record + ALvl : byte; + ObjID : nwLong; + end; + begin + {API: Get Bindery Access Level} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $46); + FillChar(Reply, sizeof(Reply), 0); + Status := nwServerCall(Server, $17, Request.Size+2, Request, + sizeof(Reply), Reply); + if (Status = 0) then + begin + AccessLevel := Reply.ALvl; + ObjID := Reply.ObjID; + end; + nwbGetBinderyAccessLevel := Status; + end; + +function nwbGetObjectID(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + var ObjID : nwLong) : TnwErrorCode; + var + Reply : record + ObjI : nwLong; + ObjT : word; + ObjN : array [0..47] of char; + end; + Status : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + {API: Get Bindery Object ID} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $35); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + FillChar(Reply, sizeof(Reply), 0); + Status := nwServerCall(Server, $17, Request.Size+2, Request, + sizeof(Reply), Reply); + if (Status = 0) then + with Reply do + begin + ObjID := ObjI; + ObjType := Swap(ObjT); + Move(ObjN, ObjName, sizeof(TnwObjectStr)); + nwCvtAsciizToStr(ObjName, pred(sizeof(TnwObjectStr))); + end; + nwbGetObjectID := Status; + end; + +function nwbGetObjectName(Server : TnwServer; + ObjID : nwLong; + var ObjType : word; + var ObjName : TnwObjectStr) : TnwErrorCode; + var + Reply : record + ObjI : nwLong; + ObjT : word; + ObjN : array [0..47] of char; + end; + Status : word; + Request : TReqBuffer; + begin + {API: Get Bindery Object Name} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $36); + nwbPackLong(Request, ObjID); + FillChar(Reply, sizeof(Reply), 0); + Status := nwServerCall(Server, $17, Request.Size+2, Request, + sizeof(Reply), Reply); + if (Status = 0) then + with Reply do + begin + ObjType := Swap(ObjT); + Move(ObjN, ObjName, sizeof(TnwObjectStr)); + nwCvtAsciizToStr(ObjName, pred(sizeof(TnwObjectStr))); + end; + nwbGetObjectName := Status; + end; + +function nwbIsObjectInSet(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr; + MemberObjType : word; + MemberObjName : TnwObjectStr) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + nwUpperStr(PropName); + nwUpperStr(MemberObjName); + {API: Is Bindery Object In Set} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $43); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbPackString(Request, PropName); + nwbPackWord(Request, MemberObjType); + nwbPackString(Request, MemberObjName); + nwbIsObjectInSet := nwServerCall(Server, $17, Request.Size+2, Request, + 0, Dummy); + end; + +function nwbOpenBindery(Server : TnwServer) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + {API: Open Bindery} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $45); + nwbOpenBindery := nwServerCall(Server, $17, Request.Size+2, Request, + 0, Dummy); + end; + +function nwbReadPropertyValue(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr; + SegmentNumber : byte; + var PropValue : TnwPropValue; + var PropIsDynamic: boolean; + var PropIsSet : boolean; + var MoreSegments : boolean) : TnwErrorCode; + var + Reply : record + Prop: TnwPropValue; + More: byte; + Flgs: byte; + end; + Status : word; + i : integer; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + nwUpperStr(PropName); + {API: Read Property Value} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $3D); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbPackByte(Request, SegmentNumber); + nwbPackString(Request, PropName); + FillChar(Reply, sizeof(Reply), 0); + Status := nwServerCall(Server, $17, Request.Size+2, Request, + sizeof(Reply), Reply); + if (Status = 0) then + with Reply do + begin + PropIsDynamic := (Flgs and $01) <> 0; + PropIsSet := (Flgs and $02) <> 0; + PropValue := Prop; + MoreSegments := More <> 0; + end; + nwbReadPropertyValue := Status; + end; + +function nwbRenameObject(Server : TnwServer; + ObjType : word; + OldObjName, + NewObjName : TnwObjectStr) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + nwUpperStr(OldObjName); + nwUpperStr(NewObjName); + {API: Rename Bindery Object} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $34); + nwbPackWord(Request, ObjType); + nwbPackString(Request, OldObjName); + nwbPackString(Request, NewObjName); + nwbRenameObject := nwServerCall(Server, $17, Request.Size+2, Request, + 0, Dummy); + end; + +function nwbScanObject(Server : TnwServer; + var ObjType : word; + var ObjName : TnwObjectStr; + var ObjID : nwLong; + var ObjIsDynamic : boolean; + var ObjSecurity : byte; + var HasProperties : boolean) : TnwErrorCode; + var + Status : word; + Request : TReqBuffer; + Reply : record + ObjI: nwLong; + ObjT: word; + ObjN: array [0..47] of char; + ObjF: byte; + ObjS: byte; + ObjP: byte; + end; + begin + nwUpperStr(ObjName); + {API: Scan Bindery Object} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $37); + nwbPackLong(Request, ObjID); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + FillChar(Reply, sizeof(Reply), 0); + Status := nwServerCall(Server, $17, Request.Size+2, Request, + sizeof(Reply), Reply); + if (Status = 0) then + with Reply do + begin + ObjID := ObjI; + ObjType := Swap(ObjT); + Move(ObjN, ObjName, sizeof(TnwObjectStr)); + nwCvtAsciizToStr(ObjName, pred(sizeof(TnwObjectStr))); + ObjIsDynamic := (ObjF and $01) <> 0; + ObjSecurity := ObjS; + HasProperties := ObjP <> 0; + end; + nwbScanObject := Status; + end; + +function nwbScanProperty(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + var Sequence : nwLong; + var PropName : TnwPropStr; + var PropIsDynamic: boolean; + var PropIsSet : boolean; + var PropSecurity : byte; + var HasValue : boolean; + var MoreProps: boolean) : TnwErrorCode; + var + Reply : record + PNam: array [0..15] of char; + PFlg: byte; + PSec: byte; + SeqN: nwLong; + PVal: byte; + PMor: byte; + end; + Status : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + nwUpperStr(PropName); + {API: Scan Property} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $3C); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbPackLong(Request, Sequence); + nwbPackString(Request, PropName); + FillChar(Reply, sizeof(Reply), 0); + Status := nwServerCall(Server, $17, Request.Size+2, Request, + sizeof(Reply), Reply); + if (Status = 0) then + with Reply do + begin + Move(PNam, PropName, sizeof(TnwPropStr)); + nwCvtAsciizToStr(PropName, pred(sizeof(TnwPropStr))); + PropIsDynamic := (PFlg and $01) <> 0; + PropIsSet := (PFlg and $02) <> 0; + PropSecurity := PSec; + Sequence := SeqN; + HasValue := PVal <> 0; + MoreProps := PMor <> 0; + end; + nwbScanProperty := Status; + end; + +function nwbVerifyPassword(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + Password: TnwPasswordStr) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + {API: Verify Bindery Object Password} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $3F); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbPackString(Request, Password); + nwbVerifyPassword := nwServerCall(Server, $17, Request.Size+2, Request, + 0, Dummy); + end; + +function nwbWritePropertyValue(Server : TnwServer; + ObjType : word; + ObjName : TnwObjectStr; + PropName: TnwPropStr; + SegmentNumber : byte; + var PropValue : TnwPropValue; + EraseRemainingSegments : boolean) : TnwErrorCode; + var + Dummy : word; + Request : TReqBuffer; + begin + nwUpperStr(ObjName); + nwUpperStr(PropName); + {API: Write Property Value} + FillChar(Request, sizeof(Request), 0); + nwbPackByte(Request, $3E); + nwbPackWord(Request, ObjType); + nwbPackString(Request, ObjName); + nwbPackByte(Request, SegmentNumber); + nwbPackByte(Request, byte(EraseRemainingSegments)); + nwbPackString(Request, PropName); + with Request do + begin + Move(PropValue, Data[Size], sizeof(TnwPropValue)); + inc(Size, sizeof(TnwPropValue)); + end; + nwbWritePropertyValue := nwServerCall(Server, $17, + Request.Size+2, Request, + 0, Dummy); + end; + +end. + diff --git a/src/wc_sdk/nwconn.pas b/src/wc_sdk/nwconn.pas new file mode 100644 index 0000000..048dc1c --- /dev/null +++ b/src/wc_sdk/nwconn.pas @@ -0,0 +1,713 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$B+,F-,I-,R-,S-,V-} + {$IFDEF CanAllowOverlays} + {$F+,O+,A-} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-,P-} + {$ENDIF} + {all other compiler options are 'don't care'} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit NWConn; + {-Unit to provide connection related NetWare functionality.} + +interface + +uses + {$IFDEF DPMIOrWnd} + DPMI, + {$ENDIF} + NWBase, + NWBind; + +const + {Max number of networks in TnwNetworkList} + MaxNetworks = 8; + +type + {A NetWare server name} + TnwServerName = TnwObjectStr; + + {Function type for enumerating servers, return true to continue + enumerating servers.} + TnwEnumServerFunc = function (Name : TnwServerName; + Server : word; + var ExtraData) : boolean; + + {Assorted server information} + TnwServerInfo = record + ServerName : TnwServerName; {..name} + NetWareVer : byte; {..major version number} + NetWareSub : byte; {..minor version number} + MaxConns : word; {..max connections can support} + UsedConns : word; {..current connections} + MaxVols : word; {..max volumes} + Revision : byte; {..version revision level} + SFTLevel : byte; {..SFT level} + TTSLevel : byte; {..TTS level} + PeakConn : word; {..max connections ever used} + AccountVer : byte; {..accounting version number} + VAPVer : byte; {..VAP version number} + QueueVer : byte; {..QMS version number} + PrintServVer: byte; {..Print server version number} + VirtualVer : byte; {..Virtual console version number} + SecurityVer : byte; {..Security Restriction version number} + BridgeVer : byte; {..Bridge Support version number} + Reserved : array [1..60] of byte; + end; + + {Information about a connection} + TnwConnInfo = record + ObjectID : nwLong; {..the logged in object's ID} + ObjectType : word; {..the logged in object's type} + ObjectName : TnwObjectStr; {..the name of the object} + LoginDate : TnwDate; {..the time/date the object logged on} + end; + + {A list of connection numbers} + PnwConnList = ^TnwConnList; + TnwConnList = record + Count : word; + List : array [0..126] of word; {in practice: variably sized} + end; + + {A list of network numbers} + TnwNetworkList = record + Count : word; {num elements in List} + List : array [1..MaxNetworks] of nwLong; {network numbers} + end; + +function nwDefaultServer : TnwServer; + {-Return the default server handle.} + +procedure nwEnumServers(EnumFunc : TnwEnumServerFunc; var ExtraData); + {-Enumerate the attached servers} + +function nwIsLoggedIn(Server : TnwServer) : boolean; + {-Return true if this workstation is logged in to the server.} + +function nwServerFromName(Name : TnwServerName) : TnwServer; + {-Return the handle for a given server name.} + +function nwServerVersion(Server : TnwServer) : word; + {-Return the server version (hibyte=major, lobyte=minor).} + +function nwGetServerInfo(Server : TnwServer; var SI : TnwServerInfo) : TnwErrorCode; + {-Return information about a server, including its name.} + +function nwGetServerTime(Server : TnwServer; var DT : TnwDate) : TnwErrorCode; + {-Return the server's date and time.} + +function nwSetServerTime(Server : TnwServer; var DT : TnwDate) : TnwErrorCode; + {-Set the server's date and time.} + +function nwGetConnNo(Server : TnwServer) : word; + {-Return the connection number of the current workstation.} + +function nwGetConnInfo(Server : TnwServer; ConnNo : word; + var CI : TnwConnInfo) : TnwErrorCode; + {-Return info about a connection number.} + +function nwGetConnNoForUser(Server : TnwServer; + UserName : TnwObjectStr; + var ConnNo : word) : TnwErrorCode; + {-Return connect number greater than ConnNo for a user name.} + +function nwGetInternetAddress(Server : TnwServer; + ConnNo : word; + var IA : IPXAddress) : TnwErrorCode; + {-Return network address for a connection.} + +procedure nwGetNetworkList(Server : TnwServer; + var NetList : TnwNetworkList); + {-Return a list of network numbers.} + +implementation + +type + OS = record O, S : word; end; {to split pointer into sel/seg & ofs} + LH = record L, H : word; end; {to split nwLong into hi/lo words} + +type + TServerNameExtraData = record {for nwServerFromName} + Handle : TnwServer; + Name : TnwServerName; + end; + +function vlmCONNGetEntryField(Server : TnwServer; FieldNum : byte) : word; + {-Return the specified connection table entry field. VLM ONLY. + Warning: this routine will trash memory for FieldNum = 17, as this + field requires a buffer to be passed. No check is made as + this routine in not (yet) called for that field.} + var + Regs : TnwRegisters; + begin + {API: _CONN Get Entry Field} + nwInitRegs(Regs); + Regs.BH := FieldNum; + Regs.CX := Server; + if (vlmCall(vlmConn, $07, Regs) = 0) then + vlmCONNGetEntryField := Regs.DX + else vlmCONNGetEntryField := 0; + end; + +procedure vlmEnumServers(EnumFunc : TnwEnumServerFunc; var ExtraData); + {-Enumerate servers under VLM.} + type + PName = ^TnwServerName; + var + LastHandle : word; + vlmResult : word; + NextName : TnwServerName; + Regs : TnwRegisters; + StillEnumerating : boolean; + begin + StillEnumerating := true; + LastHandle := 0; + while StillEnumerating do + begin + {API: _CONN Lookup Handle} + {get next server handle} + nwInitRegs(Regs); + Regs.BH := $11; + Regs.CX := LastHandle; + vlmResult := vlmCall(vlmConn, $0A, Regs); + if (vlmResult <> 0) then + StillEnumerating := false + else + begin + LastHandle := Regs.CX; + {API: _CONN Name Lookup} + {get name corresponding to handle} + nwInitRegs(Regs); + with Regs do + begin + CX := LastHandle; + {ES := OS(nwGlobalBufRealPtr).S;} {!!.51} + {DI := OS(nwGlobalBufRealPtr).O;} {!!.51} + ES := OS(nwGlobalBufVLM).S; {!!.51} + DI := OS(nwGlobalBufVLM).O; {!!.51} + end; + vlmResult := vlmCall(vlmConn, $0D, Regs); + if (vlmResult <> 0) then + StillEnumerating := false + else + begin + {convert to pascal style} + nwCvtAsciizToStr(nwGlobalBuf^, pred(sizeof(TnwServerName))); + {call user routine} + StillEnumerating := + EnumFunc(PName(nwGlobalBuf)^, LastHandle, ExtraData); + end; + end; + end; + end; + +procedure NETXEnumServers(EnumFunc : TnwEnumServerFunc; var ExtraData); + {-Enumerate servers under NETX.} + var + NameTable : PNETXServerNameTable; + LastHandle : word; + Index : integer; + NextName : TnwServerName; + begin + NameTable := nwNETXGetServerNameTable; + if (NameTable <> nil) then + begin + LastHandle := 0; + while (LastHandle < 8) do + begin + inc(LastHandle); + Move(NameTable^[LastHandle], NextName, sizeof(NextName)); + {If NextName[0] = #0 then both the ASCIIZ and the Pascal + string are empty, so NextName = ''. If not then both the + ASCIIZ and Pascal strings are not empty.} + if (NextName <> '') then + begin + {convert to Pascal style} + nwCvtAsciizToStr(NextName, pred(sizeof(TnwServerName))); + {call user routine} + if not EnumFunc(NextName, LastHandle, ExtraData) then + LastHandle := 8; {to exit from loop} + end; + end; + end; + end; + +procedure nwEnumServers(EnumFunc : TnwEnumServerFunc; var ExtraData); + begin + case nwShellType of + nsNETX : NETXEnumServers(EnumFunc, ExtraData); + nsVLM : VLMEnumServers(EnumFunc, ExtraData); + end;{case} + end; + +function vlmGetPrimaryServerHandle : TnwServer; + {-Gets the handle of the primary server. VLM ONLY.} + var + Regs : TnwRegisters; + begin + {API: _GEN Specific} + nwInitRegs(Regs); + Regs.BX := 1; + if (vlmCall(vlmGeneral, $06, Regs) <> 0) then + vlmGetPrimaryServerHandle := 0 + else vlmGetPrimaryServerHandle := Regs.CX + end; + +function NETXGetDefServer : TnwServer; assembler; + {-Gets the handle of the pref/default server. NETX ONLY.} + asm + {API: Get Preferred/Default/Primary Connection ID} + mov ax, $F001 {get preferred connection id} + int $21 + or al, al + jnz @@Exit + mov ax, $F002 {get default connection id} + int $21 + or al, al + jnz @@Exit + mov ax, $F005 {get primary connection id} + int $21 + @@Exit: + xor ah, ah + end; + +function nwDefaultServer : TnwServer; + begin + case nwShellType of + nsNETX : nwDefaultServer := NETXGetDefServer; + nsVLM : nwDefaultServer := vlmGetPrimaryServerHandle; + else + nwDefaultServer := 0; {if no shell, the server handle is zero} + end;{case} + end; + +function NETXGetServerVer(Server : TnwServer) : word; + {-Return the version of the server. NETX ONLY} + var + SI : TnwServerInfo; + begin + if (nwGetServerInfo(Server, SI) = 0) then + NETXGetServerVer := (word(SI.NetWareVer) * $100) + SI.NetWareSub + else NETXGetServerVer := 0; + end; + +function nwServerVersion(Server : TnwServer) : word; + begin + case nwShellType of + nsNETX : nwServerVersion := NETXGetServerVer(Server); + nsVLM : nwServerVersion := Swap(vlmCONNGetEntryField(Server, $08)); + else + nwServerVersion := 0; {if no shell, the server version is zero} + end;{case} + end; + +function nwGetServerInfo(Server : TnwServer; var SI : TnwServerInfo) : TnwErrorCode; + var + Request : record + Len : word; + Func : byte; + end; + Status : word; + begin + {API: Get File Server Information} + Request.Len := 1; + Request.Func := $11; + Status := nwServerCall(Server, $17, sizeof(Request), Request, + sizeof(SI), SI); + if (Status = 0) then + with SI do + begin + nwCvtAsciizToStr(ServerName, pred(sizeof(TnwServerName))); + MaxConns := Swap(MaxConns); + UsedConns := Swap(UsedConns); + MaxVols := Swap(MaxVols); + PeakConn := Swap(PeakConn); + end + else + FillChar(SI, sizeof(SI), 0); + nwGetServerInfo := Status; + end; + +function NETXGetConnNo(Server : TnwServer) : word; + {-Return our connection number. NETX ONLY} + begin + {API: Get Connection Number} + nwNETXPushServer(Server); + asm + mov ax, $DC00 + int $21 + cmp cl, 'X' {if CL = 'X' then under 1000-user NetWare} + je @@Exit { and AX = connection number} + xor ah, ah + @@Exit: + mov @Result, ax + end; + nwNETXPopServer; + end; + +function nwGetConnNo(Server : TnwServer) : word; + begin + case nwShellType of + nsNETX : nwGetConnNo := NETXGetConnNo(Server); + nsVLM : nwGetConnNo := vlmCONNGetEntryField(Server, $0D); + else + nwGetConnNo := nwErrShell; + end;{case} + end; + +function nwGetConnInfo(Server : TnwServer; ConnNo : word; + var CI : TnwConnInfo) : TnwErrorCode; + var + Request : record + Len : word; + Func : byte; + case byte of + 1 : (ConnOld : byte); + 2 : (ConnNew : nwLong); + end; + Reply : record + ObjID : nwLong; + ObjTp : word; + ObjNm : TnwObjectStr; + LogTm : array [0..6] of byte; + Fill : byte; + end; + Status : word; + begin + {API: Get Connection Information (& old)} + with Request do + if (nwServerVersion(Server) >= ServerVersion311) then + begin + Len := sizeof(Request) - 2; + Func := $1C; + ConnNew := nwLong(ConnNo); + end + else + begin + Len := sizeof(Request) - 2 + (sizeof(byte) - sizeof(nwLong)); + Func := $16; + ConnOld := lo(ConnNo); + end; + Status := nwServerCall(Server, $17, Request.Len+2, Request, + sizeof(Reply), Reply); + FillChar(CI, sizeof(TnwConnInfo), 0); + if (Status = 0) then + with CI, Reply do + begin + ObjectID := ObjID; + ObjectType := Swap(ObjTp); + nwCvtAsciizToStr(ObjNm, pred(sizeof(TnwObjectStr))); + ObjectName := ObjNm; + Move(LogTm[1], CI.LoginDate.Month, sizeof(TnwDate)-2); + if (LogTm[0] >= 80) then + CI.LoginDate.Year := 1900 + LogTm[0] + else CI.LoginDate.Year := 2000 + LogTm[0]; + end; + nwGetConnInfo := Status; + end; + +function nwGetConnNoForUser(Server : TnwServer; + UserName : TnwObjectStr; + var ConnNo : word) : TnwErrorCode; + var + Request : record + Len : word; + Func : byte; + case boolean of + true : (ConnNew : nwLong; + ObjTpNew : word; + ObjNmNew : TnwObjectStr); + false: (ObjTpOld : word; + ObjNmOld : TnwObjectStr); + end; + Reply : record {256 bytes} + ListLen : byte; + case boolean of + true : (ListNew : array [0..62] of nwLong); + false: (ListOld : array [0..254] of byte); + end; + Status : word; + i : integer; + NewCall : boolean; + StillSearching : boolean; + begin + {API: Get Object Connection List (& old)} + with Request do + if (nwServerVersion(Server) >= ServerVersion311) then + begin + NewCall := true; + Len := 8 + length(UserName); + Func := $1B; + ConnNew := nwLong(ConnNo); + ObjTpNew := Swap($0001); + ObjNmNew := UserName; + nwUpperStr(ObjNmNew); + end + else + begin + NewCall := false; + Len := 6 + length(UserName); + Func := $15; + ObjTpOld := Swap($0001); + ObjNmOld := UserName; + nwUpperStr(ObjNmOld); + end; + Status := nwServerCall(Server, $17, Request.Len+2, Request, + sizeof(Reply), Reply); + if (Status = 0) then + if (Reply.ListLen = 0) then + Status := nwErrNoMoreConns + else + if NewCall then + ConnNo := Reply.ListNew[0] + else + begin + i := 0; + StillSearching := true; + while StillSearching and (i < Reply.ListLen) do + begin + if (Reply.ListOld[i] > ConnNo) then + begin + StillSearching := false; + ConnNo := Reply.ListOld[i]; + end; + inc(i); + end; + if StillSearching then + Status := nwErrNoMoreConns; + end; + nwGetConnNoForUser := Status; + end; + +function nwGetInternetAddress(Server : TnwServer; + ConnNo : word; + var IA : IPXAddress) : TnwErrorCode; + var + Request : record + Len : word; + Func : byte; + case boolean of + true : (ConnNew : nwLong); + false: (ConnOld : byte); + end; + Reply : record + IPXAdd : IPXAddress; + CType : byte; + end; + ReplyLen : word; + Status : word; + begin + {API: Get Internet Address (& old)} + with Request do + if (nwServerVersion(Server) >= ServerVersion311) then + begin + Len := 5; + Func := $1A; + ConnNew := nwLong(ConnNo); + ReplyLen := 13; + end + else + begin + Len := 2; + Func := $13; + ConnOld := ConnNo; + ReplyLen := 12; + end; + Status := nwServerCall(Server, $17, Request.Len+2, Request, + ReplyLen, Reply); + if (Status = 0) then + begin + Move(Reply.IPXAdd, IA, sizeof(IPXAddress)); + end + else + FillChar(IA, sizeof(IPXAddress), 0); + nwGetInternetAddress := Status; + end; + +function nwGetServerTime(Server : TnwServer; var DT : TnwDate) : TnwErrorCode; + var + Dummy : word; + Status : word; + Reply : array [0..6] of byte; + begin + {API: Get File Server Date and Time} + Status := nwServerCall(Server, $14, 0, Dummy, + sizeof(Reply), Reply); + if (Status = 0) then + begin + Move(Reply[1], DT.Month, sizeof(Reply)-1); + if (Reply[0] >= 80) then + DT.Year := 1900 + Reply[0] + else DT.Year := 2000 + Reply[0]; + end + else + FillChar(DT, sizeof(DT), 0); + nwGetServerTime := Status; + end; + +function nwSetServerTime(Server : TnwServer; var DT : TnwDate) : TnwErrorCode; + var + Request : record + Len : word; + Func: byte; + Yr, Mo, Da, Ho, Mi, Se : byte; + end; + Dummy : word; + Status : word; + begin + {API: Set File Server Date and Time} + {do some coarse data checking} + nwSetServerTime := nwErrBadData; + with DT do + begin + if (Second > 59) then Exit; + if (Minute > 59) then Exit; + if (Hour > 23) then Exit; + if (Day = 0) or (Day > 31) then Exit; + if (Month = 0) or (Month > 12) then Exit; + if (Year < 1980) or (Year > 2079) then Exit; + end; + {do the date/time setting} + with Request do + begin + Len := sizeof(Request) - 2; + Func := $CA; + Move(DT.Month, Mo, 5); + if (DT.Year <= 1999) then + Yr := DT.Year - 1900 + else + Yr := DT.Year - 2000; + end; + nwSetServerTime := nwServerCall(Server, $17, sizeof(Request), Request, + 0, Dummy); + end; + +function FindServerHandle(Name : TnwServerName; Server : word; + var ExtraData) : boolean; far; + var + ED : TServerNameExtraData absolute ExtraData; + begin + if (Name = ED.Name) then + begin + ED.Handle := Server; + FindServerHandle := false; + end + else + FindServerHandle := true; + end; + +function nwServerFromName(Name : TnwServerName) : TnwServer; + var + ExtraData : TServerNameExtraData; + begin + FillChar(ExtraData, sizeof(ExtraData), 0); + ExtraData.Name := Name; + nwUpperStr(ExtraData.Name); + nwEnumServers(FindServerHandle, ExtraData); + nwServerFromName := ExtraData.Handle; + end; + +procedure nwGetNetworkList(Server : TnwServer; + var NetList : TnwNetworkList); + var + NetInx : word; + ConnNo : word; + CAddr : IPXAddress; + SI : TnwServerInfo; + StillLooking : boolean; + FullUp : boolean; + begin + {initialize the network list} + FillChar(NetList, sizeof(NetList), 0); + {get the server information for the number of connections} + if (nwGetServerInfo(Server, SI) <> 0) then + Exit; + + {read all the internet addresses until either we've filled the + network list or we run out of connections} + FullUp := false; + ConnNo := 0; + while (not FullUp) and (ConnNo < SI.PeakConn) do + begin + inc(ConnNo); + if (nwGetInternetAddress(Server, ConnNo, CAddr) = 0) then + with NetList do + begin + {try to find this new network number in the list} + StillLooking := true; + NetInx := 0; + while StillLooking and (NetInx < Count) do + begin + inc(NetInx); + if (List[NetInx] = CAddr.Network) then + StillLooking := false; + end; + {if we get here and we were still looking then the + new network number wasn't in the list so add it} + if StillLooking then + if (Count < MaxNetworks) then + begin + inc(Count); + List[Count] := CAddr.NetWork; + end + else + FullUp := true; + end; + end; + end; + +function NETXIsLoggedIn(Server : TnwServer) : boolean; + var + ObjID : nwLong; + Access : byte; + begin + NETXIsLoggedIn := false; + if (nwbGetBinderyAccessLevel(Server, Access, ObjID) = 0) then + NETXIsLoggedIn := (ObjID <> 0) and (ObjID <> -1); + end; + +function nwIsLoggedIn(Server : TnwServer) : boolean; + begin + case nwShellType of + nsNETX : nwIsLoggedIn := NETXIsLoggedIn(Server); + nsVLM : nwIsLoggedIn := Lo(vlmCONNGetEntryField(Server, $03)) = 1; + else + nwIsLoggedIn := false; + end; + end; + +end. diff --git a/src/wc_sdk/nwfile.pas b/src/wc_sdk/nwfile.pas new file mode 100644 index 0000000..e38c560 --- /dev/null +++ b/src/wc_sdk/nwfile.pas @@ -0,0 +1,1171 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$B+,F-,I-,R-,S-,V-} + {$IFDEF CanAllowOverlays} + {$F+,O+,A-} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-,P-} + {$ENDIF} + {all other compiler options are 'don't care'} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit NWFile; + {-Unit to provide NetWare file I/O functionality.} + +interface + +uses + NWBase, + NWConn; + +const + {NWFILE extra error codes} + nwfErrUnknownServer = $7F21; {Server name not found} + nwfErrUnknownVolume = $7F22; {Volume name not found} + nwfErrNotOnServer = $7F23; {Path is not on a server} + nwfErrNoFileName = $7F24; {Filename missing} {!!.51} + nwfErrUNCTooShort = $7F31; {UNC: filename < 7 chars} + nwfErrUNCBadStart = $7F32; {UNC: filename didn't start with '\\'} + nwfErrUNCBadServer = $7F33; {UNC: server name < 2 chars} + nwfErrUNCBadVolume = $7F34; {UNC: volume name < 2 chars} + nwfErrUNCBadRoot = $7F35; {UNC: \\ after volume name} + nwfErrNWBadServer = $7F41; {NW: unknown server name} + nwfErrNWBadVolume = $7F42; {NW: unknown volume name} + nwfErrDOSBadDrive = $7F51; {DOS: bad drive letter} + +const + {Extra normal file attributes} + nwfaExecuteOnly = $08; {File is executable program} + nwfaShareable = $80; {File is shareable w/o opening as shared} + + {Extended file attributes} + nweaSearchMode = $07; {Data file search mode bits for program} + nweaTransactional = $10; {File is transactional} + nweaIndexed = $20; {File is indexed for fast random access} + nweaReadAudit = $40; {File is read auditable} + nweaWriteAudit = $80; {File is write auditable} + +const + {Directory rights bits} + nwdrRead = $01; {..read files} + nwdrWrite = $02; {..write to files} + nwdrOpen = $04; {..open files} + nwdrCreate = $08; {..create new files} + nwdrDelete = $10; {..delete files} + nwdrOwner = $20; {..modify trustee tights} + nwdrSearch = $40; {..scan for files and subdirectories} + nwdrModify = $80; {..modify filenames and attributes} + +type + {A NetWare volume name, including the terminating colon (:)} + TnwVolumeName = string[17]; + + {A NetWare file handle} + TnwFileHandle = array [0..2] of word; + +function nwParseFileName(FileName : string; + var Server : TnwServer; + var ServerName : TnwServerName; + var VolumeName : TnwVolumeName; + var Path : string) : TnwErrorCode; + {-Parses a filename in UNC, DOS or NetWare format into a Server handle + and name, volume name and remaining path. The server and volume are + guaranteed to exist, but the path is not. + ServerName will be just the server name. + VolumeName will be the volume name terminated with a colon. + Path will be the remaining path from FileName, augmented to start from + the root directory of the volume. It will *not* have a leading '\', + hence if it is the root directory, Path = ''. + If the file name is on a local drive, Server will be set to zero, + ServerName to '', VolumeName will be set to the drive letter plus + colon and Path to the full path from the root directory on that drive. + Again Path will not have a leading '\'. + + A UNC filename has the form: + \\SERVER\VOLUME\DIR\..DIR\FILENAME.EXT + A NetWare filename has the form: + [SERVER\]VOLUME:DIR\..DIR\FILENAME.EXT + where if the SERVER part is missing, it is assumed to be the current + default server; VOLUME is assumed to be 2 or more characters long. + Any other filename is assumed to be in DOS format. Drive letters will + be mapped to the correct server handle.} + +function nwGetFileAttr(FileName : string; + var FAttr : byte; + var ExtFAttr : byte) : TnwErrorCode; + {-Return the file attributes for a file on a NetWare server.} + +function nwSetFileAttr(FileName : string; + FAttr : byte; + ExtFAttr : byte) : TnwErrorCode; + {-Set the file attributes for a file on a NetWare server.} + +function nwUNCtoNetWare(UNC : string; var NW : string) : TnwErrorCode; + {-Convert UNC filename (\\server\volume\path) into NetWare style + (server\volume:path). + Returns: + 0 - all OK + $7F31 - not long enough (should be >= 7 chars) + $7F32 - doesn't start with \\ + $7F33 - server name not long enough (should be >= 2 chars), + or filename just consists of server part + $7F34 - volume name not long enough (should be >= 2 chars) + $7F35 - there's two \ after the volume name} + +function nwLockRecord(Handle : word; + Start, Len : nwLong; + TimeOut : word) : TnwErrorCode; + {-Lock a region of a file.} + +function nwUnlockRecord(Handle : word; + Start, Len : nwLong) : TnwErrorCode; + {-Unlock a region of a file, previously locked by nwLockRecord.} + +function nwGetDirRights(FileName : string; + var EffRightsMask : byte) : TnwErrorCode; {!!.51} + {-Get the rights mask for a directory for the current user} + +implementation + +type + OS = record O, S : word; end; {to split pointer into sel/seg & ofs} + LH = record L, H : word; end; {to split nwLong into hi/lo words} + +type + TFileInfo = array [0..77] of byte; + +function PosCh(C : char; S : string) : integer; near; + {-Return the position of character C in S, or zero if not found} +assembler; + asm + xor cx, cx {zero the counter} + mov bx, cx {set result register to zero} + les di, S {get the string} + mov cl, es:[di] {get the string length} + jcxz @@Exit {check there's something to do} + mov dx, cx {save for later calc} + inc di {point to first character} + mov al, C {get character to look for} + cld {forwards!} + repne scasb {scan for character} + jne @@Exit {not found: exit} + sub dx, cx {calculate char position} + mov bx, dx {set in result register} + @@Exit: + xchg ax, bx {move result to ax} + end; + +procedure ReplaceSlashes(var S : string); near; + {-Change all forward slashes to backward ones in S.} +assembler; + asm + les di, S + cld + xor cx, cx + mov cl, es:[di] + inc di + mov ax, '\/' + @@Again: + repne scasb + jne @@Exit + mov es:[di-1], ah + or cx, cx + jnz @@Again + @@Exit: + end; + +procedure ConcatChar(var S : string; C : char); near; assembler; + {Concatenate a character onto the end of a string, no checking} + asm + xor bx, bx + les di, S + mov bl, es:[di] + inc bx + mov es:[di], bl + mov al, C + mov es:[di+bx], al + end; + +procedure AppendStr(var ToSt, FromSt : string; + FromCh, NumCh : byte); near; assembler; + {Append NumCh chars from FromSt[FromCh] to the end of ToSt} + asm + mov dx, ds {save Pascal's DS} + xor ax, ax {Zero ax, bx, cx} + mov bx, ax + mov cx, ax + lds si, FromSt {point ds:si at FromSt} + mov cl, [si] {get length of FromSt} + mov bl, FromCh {get start char pos} + or bx, bx {..if zero make it 1} + jnz @@FromChNot0 + inc bx + @@FromChNot0: + cmp bx, cx {is start char beyond end of string?} + ja @@Exit {yes, so nothing to do} + add si, bx {point to start char} + sub cx, bx {calc num of chars remaining in string} + inc cx + mov bl, NumCh {get num chars required} + cmp bx, cx {calc actual num chars to move} + ja @@NoTrimming + mov cx, bx + @@NoTrimming: + les di, ToSt {point es:di at ToSt} + mov al, es:[di] {get the ToSt length} + mov bx, ax {save it for now} + add al, cl {calc new ToSt length} + jno @@NoOverflow + mov ax, 255 + @@NoOverflow: + mov es:[di], al {set ToSt length} + add di, bx {point es:di at dest char} + inc di + shr cx, 1 {copy ToSt to FromSt} + rep movsw + adc cx, cx + rep movsb + @@Exit: + mov ds, dx {restore Pascal's DS} + end; + +function nwGetVolumeNumber(Server : TnwServer; Name : TnwVolumeName; + var VolNumber : byte) : TnwErrorCode; + {-Return the volume number for a volume name.} + var + Request : record + Len : word; + Func : byte; + VolN : TnwVolumeName; + end; + Reply : byte; + Status : word; + begin + {API: Get Volume Number} + with Request do + begin + Len := 2 + length(Name); + Func := $05; + VolN := Name; + dec(VolN[0]); {remove the colon} + nwUpperStr(VolN); + end; + Status := nwServerCall(Server, $16, Request.Len+2, Request, + sizeof(Reply), Reply); + if (Status = 0) then + VolNumber := Reply; + nwGetVolumeNumber := Status; + end; + +function nwUNCtoNetWare(UNC : string; var NW : string) : TnwErrorCode; +assembler; + asm + push ds {save Pascal's DS} + xor bx, bx {zeroise BX} + mov cx, bx {..and CX} + + lds si, UNC {get the UNC filename} + les di, NW {get the NW result filename} + cld {forwards!} + lodsb {get length of UNC filename} + mov cl, al {set CX to the length} + + xchg bh, al {store orig length in BH} + stosb {set the result length to zero} + + mov bl, $31 {assume error nwfErrUNCTooShort} + cmp cx, 7 {is source length 7 or more} + jb @@Error {no - report error} + + inc bl {assume error nwfErrUNCBadStart} + lodsw {get first two chars} + cmp ax, '\\' {..are they '\\'?} + jne @@Error {no - report error} + + dec cx {decrement chars left} + dec cx + + inc bl {assume error nwfErrUNCBadServer} + xor dx, dx {zeroise length of server string} + @@State1Loop: + lodsb {get next char} + stosb {store it in result} + dec cx {decrement chars left} + jz @@Error {zero? yes - report error} + cmp al, '\' {is char a '\'?} + je @@State1Exit {yes - exit server loop} + inc dx {increment num chars in server part} + jmp @@State1Loop {go get next char} + @@State1Exit: + cmp dx, 2 {is server part long enough?} + jb @@Error {no - report error} + + inc bl {assume error nwfErrUNCBadVolume} + xor dx, dx {zeroise length of volume string} + @@State2Loop: + lodsb {get next char} + cmp al, '\' {is char a '\'?} + je @@State2Exit {yes - exit volume loop} + stosb {store char in result} + inc dx {increment num chars in volume part} + dec cx {decrement chars left} + jnz @@State2Loop {if more, go get next char} + @@State2Exit: + cmp dx, 2 {is volume part long enough?} + jb @@Error {no - report error} + mov al, ':' {terminate the volume name} + stosb {..with a ':'} + or cx, cx {cx=0 => no '\'; is this so?} + jnz @@DoTheRest {no - go process rest of string} + inc bh {take account of ':'} + jmp @@StoreLength {go set the result length} + + @@Error: + mov ax, $7F00 {set AX, the function result} + mov al, bl {set the error code} + jmp @@Exit {..and exit} + + @@DoTheRest: + dec cx {take account of last '\' read} + jz @@StoreLength {any more chars left? no - go set length} + inc bl {assume error nwfErrUNCBadRoot} + cmp byte ptr [si], '\' {are there two '\' after volume?} + je @@Error {yes - report error} + shr cx, 1 {copy rest of characters} + rep movsw + adc cx, cx + rep movsb + + @@StoreLength: + xor ax, ax {zeroise AX} + xchg bh, al {get length byte} + dec al {subtract 2 for the initial '\\'} + dec al + sub di, ax {point to start of result string} + dec di + pop ds {get back Pascal's DS because} + push ds { nwUpperStr is a global variable} + push es {push parms for nwUpperStr} + push di + stosb {store the length byte} + call nwUpperStr {uppercase the string} + xor ax, ax {function result of 0 = success} + + @@Exit: + pop ds {get back Pascal's DS} + end; + +function nwNetWareToNetWare(S : string; var NW : string) : TnwErrorCode; + {-Convert a full/partial NetWare path into a full one. Internal use.} + var + PosColon, PosSlash : integer; + LenS : integer; + SI : TnwServerInfo; + begin + PosColon := PosCh(':', S); + if (PosColon = 0) then + begin + nwNetWareToNetWare := nwfErrNWBadVolume; + Exit; + end; + PosSlash := PosCh('\', S); + if (PosSlash = 0) or (PosSlash > PosColon) then + begin + if (nwGetServerInfo(nwDefaultServer, SI) <> 0) then + begin + nwNetWareToNetWare := nwfErrNWBadServer; + Exit; + end; + NW := SI.ServerName; + ConcatChar(NW, '\'); + AppendStr(NW, S, 1, 255); + end + else + NW := S; + nwUpperStr(NW); + nwNetWareToNetWare := 0; + end; + +function NETXGetRelativeDriveDepth(Drive : char) : integer; near; + {-Return number of subdirectories deep for a map root drive. 0 means + at root, 255 means the drive is not a map root drive.} +assembler; + asm + {API: Get Relative Drive Depth} + mov ax, $E907 + mov bl, Drive + sub bl, 'A' - 1 {assumes Drive is in uppercase} + int $21 + xor ah, ah + end; + +function NETXGetDirHandle(Drive : char; + var Server : TnwServer; + var DirHandle : byte) : TnwErrorCode; near; + {-Return connection ID and directory handle for NetWare drive. NETX only.} + type + TByteTable = array ['A'..'`'] of byte; {ie 32 drives} + var + Status : word; + ByteTable : TByteTable; + begin + {API: Get Drive Connection ID} + { Get Drive Handle Table} + Status := nwNETXGetDriveTable($EF02, ByteTable); + if (Status = 0) then + begin + Server := ByteTable[Drive]; + if (Server = 0) then + Status := nwfErrUnknownServer + else + begin + Status := nwNETXGetDriveTable($EF00, ByteTable); + if (Status = 0) then + DirHandle := ByteTable[Drive]; + end; + end; + NETXGetDirHandle := Status; + end; + +function NETXGetRedir(Drive : char; var SV : string; + var MR : string; + var CD : string) : TnwErrorCode; + {-Return the server and volume names (in form 'SERVER\VOLUME:'), + the map root directory (in form 'DIR...\DIR', with root + directory returned as '') and the current directory (in form + '\DIR...\DIR' with root dir returned as '\') for drive. + ***NETX only***.} + var + DirsDeep : integer; + DirNum : integer; + i : integer; + StartPos : integer; + PosColon : integer; + Status : word; + Server : word; + Request : record + Len : word; + Func: byte; + DirH: byte; + end; + Reply : string; + SI : TnwServerInfo; + FoundOne : boolean; + begin + {API: Get Directory Path} + Status := NETXGetDirHandle(Drive, Server, Request.DirH); + if (Status <> 0) then + begin + NETXGetRedir := Status; + Exit; + end; + Request.Len := 2; + Request.Func := 1; + Status := nwServerCall(Server, $16, sizeof(Request), Request, + sizeof(Reply), Reply); + {Reply is in VOLUME:DIR\...\DIR format, sometimes with /'s instead} + ReplaceSlashes(Reply); + if (Status = 0) then + Status := nwGetServerInfo(Server, SI); + if (Status = 0) then + begin + PosColon := PosCh(':', Reply); + SV := SI.ServerName; + ConcatChar(SV, '\'); + AppendStr(SV, Reply, 1, PosColon); + DirsDeep := NETXGetRelativeDriveDepth(Drive); + if (DirsDeep = 255) then {not a map root drive} + begin + MR := ''; + CD := '\'; + AppendStr(CD, Reply, PosColon+1, 255); + end + else if (DirsDeep = 0) then + begin + CD := '\'; + MR := ''; + AppendStr(MR, Reply, PosColon+1, 255); + end + else {DirsDeep > 0} + begin + StartPos := length(Reply)+1; + for DirNum := 1 to DirsDeep do + begin + FoundOne := false; + i := StartPos-1; + while (not FoundOne) and (i > PosColon) do + if (Reply[i] = '\') then + FoundOne := true + else + dec(i); + StartPos := i; + end; + CD := '\'; + AppendStr(CD, Reply, StartPos+1, 255); + MR := ''; + AppendStr(MR, Reply, PosColon+1, StartPos-PosColon-1); + end; + end; + NETXGetRedir := Status; + end; + +function vlmGetRedir(Drive : char; var SV : string; + var MR : string; + var CD : string) : TnwErrorCode; + {-Return the server and volume names (in form 'SERVER\VOLUME:'), + the map root directory (in form 'DIR...\DIR', with root + directory returned as '') and the current directory (in form + '\DIR...\DIR' with root dir returned as '\') for drive. + ***VLM only***.} + var + Status : word; + PosColon : integer; + StartPos : integer; + Regs : TnwRegisters; + begin + {API: _REDIR Specific} + FillChar(nwGlobalBuf^, 16+512, 0); + nwGlobalBuf^[0] := ord(Drive); + nwGlobalBuf^[1] := ord(':'); + nwInitRegs(Regs); + with Regs do + begin + {DS := OS(nwGlobalBufRealPtr).S;} {!!.51} + {SI := OS(nwGlobalBufRealPtr).O;} {!!.51} + DS := OS(nwGlobalBufVLM).S; + SI := OS(nwGlobalBufVLM).O; + ES := DS; + DI := SI + 16; + end; + Status := vlmCall(vlmRedir, $08, Regs); + {reply is in \\SERVER\VOLUME\DIR...\DIR format, or + if the drive is a map root drive in + \\SERVER\VOLUME\DIR...\DIR\DIR...\DIR format} + if (Status = 0) then + begin + nwCvtAsciizToStr(nwGlobalBuf^[16], 255); + Move(nwGlobalBuf^[16], SV, nwGlobalBuf^[16]+1); + StartPos := 16+length(SV)+1; + nwCvtAsciizToStr(nwGlobalBuf^[StartPos], 255); + Move(nwGlobalBuf^[StartPos], CD, nwGlobalBuf^[StartPos]+1); + Status := nwUNCToNetWare(SV, SV); + {check for a map root drive} + PosColon := PosCh(':', SV); + MR := ''; + if (PosColon < length(SV)) then + begin + AppendStr(MR, SV, PosColon+1, 255); + SV[0] := char(PosColon); + end; + end; + vlmGetRedir := Status; + end; + +function nwGetRedir(Drive : char; var SV : string; + var MR : string; + var CD : string) : TnwErrorCode; + {-Return the server and volume names (in form 'SERVER\VOLUME:'), + the map root directory (in form 'DIR...\DIR', with root + directory returned as '') and the current directory (in form + '\DIR...\DIR' with root dir returned as '\') for drive.} + begin + case nwShellType of + nsNETX : nwGetRedir := NETXGetRedir(Drive, SV, MR, CD); + nsVLM : nwGetRedir := vlmGetRedir(Drive, SV, MR, CD); + else + nwGetRedir := nwErrShell; + end;{case} + end; + +function nwParseDOSFileName(var FileName : string; + var Server : TnwServer; + var ServerName : TnwServerName; + var VolumeName : TnwVolumeName; + var Path : string) : TnwErrorCode; + {-The version of nwParseFileName for DOS-style filenames.} + var + PosSlash, PosColon : integer; + FNLen : integer; + StrInx : integer; + Status : word; + ServerVol : string; + RootPath : string; + CurPath : string; + DriveLetter : char; + begin + nwUpperStr(FileName); + {get the drive letter} + FNLen := length(FileName); + if (FNLen > 1) and (FileName[2] = ':') then + begin + DriveLetter := FileName[1]; + if (DriveLetter < 'A') or (DriveLetter > 'Z') then + begin + nwParseDOSFileName := nwfErrDOSBadDrive; + Exit; + end; + StrInx := 3; + end + else {no drive present in FileName, use current drive} + begin + asm + mov ah, $19 + int $21 + add al, 'A' + mov DriveLetter, al + end; + StrInx := 1; + end; + {convert the drive letter to a NetWare path in netware format} + Status := nwGetRedir(DriveLetter, ServerVol, RootPath, CurPath); + if (Status = 0) then + begin + while (FNLen > StrInx) and (FileName[FNLen] = '\') do + dec(FNLen); + FileName[0] := char(FNLen); + PosSlash := PosCh('\', ServerVol); + PosColon := PosCh(':', ServerVol); + ServerName := ''; + VolumeName := ''; + AppendStr(ServerName, ServerVol, 1, PosSlash-1); + AppendStr(VolumeName, ServerVol, PosSlash+1, PosColon-PosSlash); + Server := nwServerFromName(ServerName); + Path := RootPath; + if (StrInx > FNLen) then + begin + if (length(CurPath) <> 1) then {ie CurPath <> '\'} + begin + if (Path <> '') then + ConcatChar(Path, '\'); + AppendStr(Path, CurPath, 2, 255); + end + end + else {StrInx points within FileName} + if (FileName[StrInx] = '\') then + begin + if (StrInx <> FNLen) then + begin + if (Path <> '') then + ConcatChar(Path, '\'); + AppendStr(Path, FileName, StrInx+1, 255); + end; + end + else {the StrInx'th char is not a '\'} + begin + if (length(CurPath) > 1) then + AppendStr(Path, CurPath, 1, 255); + if (Path <> '') then + ConcatChar(Path, '\'); + AppendStr(Path, FileName, StrInx, 255) + end; + end + else {it's not a NetWare drive letter} + begin + Server := 0; + ServerName := ''; + VolumeName[0] := #2; + VolumeName[1] := DriveLetter; + VolumeName[2] := ':'; + Path := ''; + while (FNLen > StrInx) and (FileName[FNLen] = '\') do + dec(FNLen); + FileName[0] := char(FNLen); + if (StrInx <= FNLen) and (FileName[StrInx] = '\') then + begin + Status := 0; + AppendStr(Path, FileName, StrInx+1, 255); + end + else {FileName's path does not start at root directory} + begin + GetDir(ord(DriveLetter) - ord('A') + 1, CurPath); + Status := IOResult; + if (Status = 0) then + begin + if (length(CurPath) = 3) then {ie CurPath = 'd:\'} + begin + if (StrInx < FNLen) then + AppendStr(Path, FileName, StrInx, 255); + end + else + begin + AppendStr(Path, CurPath, 4, 255); + if (StrInx < FNLen) then + begin + ConcatChar(Path, '\'); + AppendStr(Path, FileName, StrInx, 255) + end; + end; + end; + end; + end; + nwParseDOSFileName := Status; + end; + + +function nwParseFileName(FileName : string; + var Server : TnwServer; + var ServerName : TnwServerName; + var VolumeName : TnwVolumeName; + var Path : string) : TnwErrorCode; + var + Status : word; + PosSlash, PosColon : integer; + TempName : string; + VolNum : byte; + begin + if (FileName = '') then + begin + nwParseFileName := nwfErrNoFileName; + Exit; + end; + {Check first for a UNC filename} + if (length(FileName) >= 2) and + (FileName[1] = '\') and (FileName[2] = '\') then + Status := nwUNCToNetWare(FileName, TempName) + else + {Check next for a NetWare filename} + begin + PosColon := PosCh(':', FileName); + if (PosColon > 2) then + Status := nwNetWareToNetWare(FileName, TempName) + else {it's a DOS filename} + begin + nwParseFileName := nwParseDOSFileName(FileName, + Server, ServerName, + VolumeName, + Path); + Exit; + end; + end; + if (Status = 0) then + begin + PosSlash := PosCh('\', TempName); + if (PosSlash > sizeof(TnwServerName)) then + Status := nwfErrUnknownServer + else + begin + ServerName := ''; + AppendStr(ServerName, TempName, 1, PosSlash-1); + Server := nwServerFromName(ServerName); + if (Server = 0) then + Status := nwfErrUnknownServer + else + begin + PosColon := PosCh(':', TempName); + if (PosColon > sizeof(TnwVolumeName)+PosSlash+1) then + Status := nwfErrUnknownVolume + else + begin + VolumeName := ''; + AppendStr(VolumeName, TempName, PosSlash+1, PosColon-PosSlash); + Status := nwGetVolumeNumber(Server, VolumeName, VolNum); + if (Status <> 0) then + Status := nwfErrUnknownVolume + else + begin + Path := ''; + AppendStr(Path, TempName, PosColon+1, 255); + end; + end; + end; + end; + end; + nwParseFileName := Status; + end; + +function ScanFileInformation(Server : TnwServer; + var Path : string; + var FileInfo : TFileInfo) : TnwErrorCode; + {-NetWare's equivalent of FindFirst/FindNext.} + var + Status : word; + Request : record + Len : word; + Func : byte; + SInx : word; + Hndl : byte; + SAttr: byte; + FName: string; + end; + Reply : record + Sinx : word; + FName: array [0..13] of char; + Attr : TFileInfo; + end; + begin + {API: Scan File Information} + with Request do + begin + FName := Path; + Len := length(FName) + 6; + Func := $0F; + SInx := $FFFF; + Hndl := 0; + SAttr := $06; {include hidden & system} + end; + Status := nwServerCall(Server, $17, Request.Len+2, Request, + sizeof(Reply), Reply); + if (Status = 0) then + FileInfo := Reply.Attr; + ScanFileInformation := Status; + end; + +function SetFileInformation(Server : TnwServer; + var Path : string; + var FileInfo : TFileInfo) : TnwErrorCode; + {-Update the file's directory information.} + var + Request : record + Len : word; + Func : byte; + FAttr: TFileInfo; + Hndl : byte; + SAttr: byte; + FName: string; + end; + Dummy : word; + begin + {API: Set File Information} + with Request do + begin + FName := Path; + Len := length(FName) + 82; + Func := $10; + FAttr := FileInfo; + Hndl := 0; + SAttr := $06; {include hidden & system} + end; + SetFileInformation := nwServerCall(Server, $17, Request.Len+2, Request, + 0, Dummy); + end; + + +function nwGetFileAttr(FileName : string; + var FAttr : byte; + var ExtFAttr : byte) : TnwErrorCode; + var + Status : word; + Server : TnwServer; + ServerName : TnwServerName; + VolumeName : TnwVolumeName; + FileInfo : TFileInfo; + Path : string; + begin + Status := nwParseFileName(FileName, Server, ServerName, VolumeName, Path); + if (Status = 0) then + if (Server = 0) then + Status := nwfErrNotOnServer + else + begin + Insert(VolumeName, Path, 1); + Status := ScanFileInformation(Server, Path, FileInfo); + if (Status = 0) then + begin + FAttr := FileInfo[0]; + ExtFAttr := FileInfo[1]; + end; + end; + nwGetFileAttr := Status; + end; + +function nwSetFileAttr(FileName : string; + FAttr : byte; + ExtFAttr : byte) : TnwErrorCode; + var + Status : word; + Server : TnwServer; + ServerName : TnwServerName; + VolumeName : TnwVolumeName; + FileInfo : TFileInfo; + Path : string; + begin + Status := nwParseFileName(FileName, Server, ServerName, VolumeName, Path); + if (Status = 0) then + if (Server = 0) then + Status := nwfErrNotOnServer + else + begin + Insert(VolumeName, Path, 1); + Status := ScanFileInformation(Server, Path, FileInfo); + if (Status = 0) then + begin + FileInfo[0] := FAttr; + FileInfo[1] := ExtFAttr; + Status := SetFileInformation(Server, Path, FileInfo); + end; + end; + nwSetFileAttr := Status; + end; + +function vlmDOSToNWHandle(DOSHandle : word; + var Server: TnwServer; + var NWH : TnwFileHandle) : TnwErrorCode; + var + Status : word; + Regs : TnwRegisters; + begin + {API: _REDIR DOS To NW Handle} + nwInitRegs(Regs); + with Regs do + begin + BX := DOSHandle; + {ES := OS(nwGlobalBufRealPtr).S;} {!!.51} + {DI := OS(nwGlobalBufRealPtr).O;} {!!.51} + ES := OS(nwGlobalBufVLM).S; {!!.51} + DI := OS(nwGlobalBufVLM).O; {!!.51} + end; + Status := vlmCall(vlmRedir, $05, Regs); + if (Status = 0) then + begin + Server := Regs.CX; + Move(nwGlobalBuf^[0], NWH, sizeof(NWH)); + end; + vlmDOSToNWHandle := Status; + end; + +function vlmLockRecord(Handle : word; + Start, Len : nwLong; + TimeOut : word) : TnwErrorCode; + var + Status : word; + NWH : TnwFileHandle; + Server : TnwServer; + Request : record + Flag : byte; + Hndl : TnwFileHandle; + RgnSt : nwLong; + RgnLen: nwLong; + TimOut: word; + end; + Dummy : word; + begin + {API: Log Physical Record (old)} + {Note: the new version of Log Physical Record looks like the old + version - ???} + Status := vlmDOSToNWHandle(Handle, Server, NWH); + if (Status = 0) then + begin + with Request do + begin + Flag := $01; + Hndl := NWH; + RgnSt := nwSwapLong(Start); + RgnLen := nwSwapLong(Len); + TimOut := swap(TimeOut); {!!.52} + end; + Status := nwServerCall(Server, $1A, sizeof(Request), Request, + 0, Dummy); + end; + vlmLockRecord := Status; + end; + +function NETXLockRecord(Handle : word; + Start, Len : nwLong; + TimeOut : word) : TnwErrorCode; + var + Status : word; + Regs : TnwRegisters; + begin + {$IFDEF Windows} {!!.51 start} + Status := 0; + asm + push bp + mov ax, $BC01 + mov bx, Handle + mov cx, Start.Word[2] + mov dx, Start.Word[0] + mov si, Len.Word[2] + mov di, Len.Word[0] + mov bp, TimeOut + int $21 + pop bp + or al, al {!!.52} + jz @@Exit {!!.52} + xor ah, ah + add ax, nwErrBaseNETX + mov Status, ax + @@Exit: + end; + {$ELSE} {!!.51 end} + nwInitRegs(Regs); + with Regs do + begin + AX := $BC01; + BX := Handle; + CX := LH(Start).H; + DX := LH(Start).L; + SI := LH(Len).H; + DI := LH(Len).L; + BP := TimeOut; + end; + Status := nwIntr($21, Regs); + if (Status = 0) then + if (Regs.AL <> 0) then + Status := nwErrBaseNETX + Regs.AL; + {$ENDIF} + NETXLockRecord := Status; + end; + +function nwLockRecord(Handle : word; + Start, Len : nwLong; + TimeOut : word) : TnwErrorCode; + begin + case nwShellType of + nsNETX : nwLockRecord := NETXLockRecord(Handle, Start, Len, Timeout); + nsVLM : nwLockRecord := vlmLockRecord(Handle, Start, Len, Timeout); + else + nwLockRecord := nwErrShell; + end;{case} + end; + +function vlmUnlockRecord(Handle : word; + Start, Len : nwLong) : TnwErrorCode; + var + Status : word; + NWH : TnwFileHandle; + Server : TnwServer; + Request : record + Res : byte; + Hndl : TnwFileHandle; + RgnSt : nwLong; + RgnLen: nwLong; + end; + Dummy : word; + begin + {API: Clear Physical Record} + Status := vlmDOSToNWHandle(Handle, Server, NWH); + if (Status = 0) then + begin + with Request do + begin + Hndl := NWH; + RgnSt := nwSwapLong(Start); + RgnLen := nwSwapLong(Len); + end; + Status := nwServerCall(Server, $1E, sizeof(Request), Request, + 0, Dummy); + end; + vlmUnlockRecord := Status; + end; + +function NETXUnlockRecord(Handle : word; + Start, Len : nwLong) : TnwErrorCode; + var + Status : word; + Regs : TnwRegisters; + begin + {$IFDEF Windows} {!!.51 start} + Status := 0; + asm + mov ah, $BE + mov bx, Handle + mov cx, Start.Word[2] + mov dx, Start.Word[0] + mov si, Len.Word[2] + mov di, Len.Word[0] + int $21 + or al, al {!!.52} + jz @@Exit {!!.52} + xor ah, ah + add ax, nwErrBaseNETX + mov Status, ax + @@Exit: + end; + {$ELSE} {!!.51 end} + nwInitRegs(Regs); + with Regs do + begin + AH := $BE; + BX := Handle; + CX := LH(Start).H; + DX := LH(Start).L; + SI := LH(Len).H; + DI := LH(Len).L; + end; + Status := nwIntr($21, Regs); + if (Status = 0) then + if (Regs.AL <> 0) then + Status := nwErrBaseNETX + Regs.AL; + {$ENDIF} + NETXUnlockRecord := Status; + end; + + +function nwUnlockRecord(Handle : word; + Start, Len : nwLong) : TnwErrorCode; + begin + case nwShellType of + nsNETX : nwUnlockRecord := NETXUnlockRecord(Handle, Start, Len); + nsVLM : nwUnlockRecord := vlmUnlockRecord(Handle, Start, Len); + else + nwUnlockRecord := nwErrShell; + end;{case} + end; + +function nwGetDirRights(FileName : string; + var EffRightsMask : byte) : TnwErrorCode; {!!.51} + var + Status : word; + Server : TnwServer; + ServerName : TnwServerName; + VolumeName : TnwVolumeName; + Request : record + Len : word; + Func: byte; + DirH: byte; + Path: string; + end; + begin + Status := nwParseFileName(FileName, Server, ServerName, VolumeName, Request.Path); + if (Status = 0) then + if (Server = 0) then + Status := nwfErrNotOnServer + else + begin + System.Insert(VolumeName, Request.Path, 1); + with Request do + begin + Len := length(Path) + 3; + Func := $03; + DirH := 0; + end; + EffRightsMask := 0; + Status := nwServerCall(Server, $16, Request.Len + 2, Request, + 1, EffRightsMask); + end; + nwGetDirRights := Status; + end; + + +end. diff --git a/src/wc_sdk/nwipxspx.pas b/src/wc_sdk/nwipxspx.pas new file mode 100644 index 0000000..bda364a --- /dev/null +++ b/src/wc_sdk/nwipxspx.pas @@ -0,0 +1,2222 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$F+,V-,B-,S-,I-,R-} + {$IFDEF CanSetOvrflowCheck} + {$Q-,P-} + {$ENDIF} + {$IFDEF MSDOS} + {$O-} + {$ENDIF} + {$IFDEF Windows} + {$W-} + {$ENDIF} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit NWIPXSPX; + +interface + +uses + NWBase, + {$IFDEF Windows} + WinProcs, + WinTypes, + {$IFDEF Ver80} + DosSupp, + {$ELSE} + WinDos, + {$ENDIF} + DPMI; + {$ELSE} + {$IFNDEF FPC} + {$IFDEF DPMI} + WinAPI, + Dos, DPMI; + {$ELSE} + {$ENDIF} + {$ENDIF} + Dos; + {$ENDIF} + + +const +{---IPX/SPX Error Codes---} + {NWIPXSPX unit specific error codes} + IPXErrOutOfMemory = 1; {Either heap or DOS memory is exhausted} + IPXErrDataTooLarge = 2; {user specified data is larger than maximum} + IPXErrBadPacket = 3; {data packet was not allocated with IPXAllocPacket} + IPXErrBadEventRec = 4; {IPX event record was not allocated with IPXAllocEventRec} + AESErrBadECB = 5; {AES ECB was not allocated with AESAllocECB} + SPXErrNoConnection = 6; {the SPXEvent record has no connection} + SPXErrBadEventRec = 7; {SPX event record was not allocated with SPXAllocEventRec} + SPXErrRemoteHasGone = 8; {The remote partner called SPXTerminateConn} + IPXErrDPMIError = 9; {Some DPMI error} + SPXErrSameSockets =10; {Local and remote sockets equal} + + {Novell defined error codes} + IPXErrSocketAlreadyOpen = $FF; {attempted to open already open socket} + IPXErrSocketTableFull = $FE; {this connection may not have any more open sockets} + IPXErrCannotCancel = $F9; {the event was in a critical phase: cancel failed} + IPXErrNotActive = $FF; {the event was complete: cancel failed} + IPXErrCancelled = $FC; {the event was cancelled} + IPXErrMalformedPacket = $FD; {packet not proper size and/or format} + IPXErrPacketUndeliverable= $FE; {cannot deliver the packet} + IPXErrPhysicalError = $FF; {hardware error} + IPXErrPacketOverflow = $FD; {more data received than buffer size specified} + IPXErrSocketNotOpen = $FF; {the socket for communications is not open} + SPXErrRemoteEndedConn = $EC; {remote ended connection without receiving last packet} + SPXErrFailedConn = $ED; {SPX watchdog has noticed the connection has failed} + SPXErrInvalidConn = $EE; {non-existent connection number} + SPXErrConnTableFull = $EF; {Local SPX connection table is full} + +const +{---IPX constants---} + IPXMaxDataSize = 546; {max size of the data part of an IPX packet} + +{---SPX constants---} + SPXEndOfConn = $FE; {Data type received by SPXReceivedPacket that + means remote station called SPXTerminateConn} + SPXMaxPoolCount = 16; {max number of ECBs in an SPX listen pool} + SPXMaxDataSize = 534; {max size of the data part of an SPX packet} + +type +{---IPX / SPX Types---} + {a pointer to an IPX/SPX packet} + PPacket = pointer; + + {the header structure for IPX calls} + PipxHeader = ^TipxHeader; + TipxHeader = record + CheckSum : word; + Len : word; + TransportControl: byte; + PacketType : byte; + Destination : IPXAddress; + Source : IPXAddress; + end; + + {the record type used to represent a buffer fragment descriptor for IPX/SPX} + TipxFragment = record + Data : Pointer; {the data} + Size : word; {the size of the data} + end; + + {The IPX/SPX Event Control Block} + PipxECB = ^TipxECB; + TipxECB = record + Link : Pointer; {used internally} + ESRAddress : Pointer; {the ESR dispatcher} + InUse : byte; {in use semaphore} + CompletionCode : byte; {completion error code} + SocketNumber : word; {the session socket (hi-lo)} + IPXWorkSpace : nwLong; {reserved for internal use} + DriverWorkSpace : Array[1..12] of byte; {reserved} + ImmediateAddress: PhysicalNodeAddress; {the internet address} + FragmentCount : word; {the number of buffers} + FD1 : TipxFragment; {buffer 1} + FD2 : TipxFragment; {buffer 2} + end; + + {The IPX Event record} + PipxEventRec = ^TipxEventRec; + {..prototype for an IPX event service routine} + IPXEventServiceRoutine = procedure (FromAES : boolean; IPXEvent : PipxEventRec); + TipxEventRec = record + ECB : TipxECB; {the event record's ECB (MUST be first)} + Header : TipxHeader; {the header for the ECB} + Next : PipxEventRec; {next TipxEventRec in the linked list} + UserESR: IPXEventServiceRoutine; {the user's ESR} + end; + + {The Asynchronous Event Scheduler's Event Control Block} + PAESECB = ^TAESECB; + {..prototype for an AES special event service routine} + AESEventServiceRoutine = procedure (ECB : PAESECB); + TAESECB = record + Link : Pointer; {used internally} + ESRAddress : Pointer; {the ESR dispatcher} + InUse : byte; {in use semaphore} + AESWorkSpace : Array[1..5] of byte; {AES work area - reserved} + Next : PAESECB; {next AES ECB in linked list} + UserESR : AESEventServiceRoutine; {the user's ESR} + UserData : pointer; {pointer to any user data} + end; + + {The SPXConnStatus function sets a variable of this type} + TspxStatus = record + State : byte; + Flag : byte; + SourceConn : word; + DestConn : word; + SequenceNum : word; + AckNum : word; + AllocNum : word; + RemoteAckNum : word; + RemoteAllocNum : word; + ConnSocket : word; + ImmediateAdd : PhysicalNodeAddress; + Destination : IPXAddress; + RetransmitCount : word; + EstimatedRoundTripDelay : word; + RetransmittedPackets : word; + SuppressedPackets : word; + end; + + PspxHeader = ^TspxHeader; + TspxHeader = record + IPXHeader : TipxHeader; + ConnectControl : byte; + DataType : byte; + SourceConnID : word; + DestConnID : word; + SequenceNo : word; + AcknowledgeNo : word; + AllocationNo : word; + end; + + PspxPoolECB = ^TspxPoolECB; + TspxPoolECB = record + PoolECB : TipxECB; {MUST be first} + PoolHeader : TspxHeader; {MUST be second} + PoolData : array [1..SPXMaxDataSize] of byte; + end; + + PspxEventRec = ^TspxEventRec; + TspxEventRec = record + ECB : TipxECB; {ECB for connecting and sending (MUST be first)} + Header : TspxHeader; {header for connecting and sending} + AmConnected: boolean; {Is set true if connected} + ConnID : word; {SPX connection id} + Next : PspxEventRec; {The next SPX record in the list} + PacketSize : word; {max packet size to transfer} + PoolCount : byte; {actual number of buffers in pool} + QueueCount : byte; {number of received buffers} + Pool : array [1..SPXMaxPoolCount] of PspxPoolECB; + {array of pointers to listen buffers} + Queue : array [1..SPXMaxPoolCount] of byte; + {array of queued buffer indexes} + end; + +const + SPXWatchDog : boolean = false; {set true to use SPX watchdog services} + SPXRetryCount : byte = 0; {indicates to use the default retry count} + + IPXAllNodes : PhysicalNodeAddress = ($FF,$FF,$FF,$FF,$FF,$FF); + +var + IPXDoNothingESR : IPXEventServiceRoutine; {a do-nothing ESR for IPX} + AESDoNothingESR : AESEventServiceRoutine; {a do-nothing ESR for AES} + + +{**************************************************** + IPX Services (Internetwork Packet Exchange Protocol) + ****************************************************} + +function IPXAllocEventRec(ESR : IPXEventServiceRoutine) : PipxEventRec; + {-Allocate an IPX event record for passing onto other IPX routines. + Notes: IPX event records passed to the IPX routines in this unit + MUST be allocated with this function, as it performs some + initializations after allocating the event record. This applies + to real-mode programming as well. ESR can be nil, or can be the + address of an event service routine that will gain control after + IPX has serviced the event that the event record will handle. + Returns either a pointer to the TipxEventRec, or nil if out of memory.} + +function IPXAllocPacket(Size : word) : PPacket; + {-Return a pointer to a memory block of Size bytes. + Notes: Under real mode this function is equivalent to GetMem, but + under protected mode or Windows, the memory block is in DOS + addressable memory. All data packets used for IPX and SPX MUST be + allocated with this function. + Returns either a pointer to the packet, or nil if out of memory.} + +function IPXCancelEvent(IPXEvent : PipxEventRec) : byte; + {-Cancel the pending IPX event. + Notes: This function cancels any pending event. If the ECB was in + use, the InUse flag gets set to zero, and the completion code is + set to IPXCancelled. However, if the IPX driver was in the process + of transferring data to/from the ECB, the cancel request will fail.} + +procedure IPXCloseSocket(Socket : word); + {-Close the specified socket. + Notes: Closing a socket will automatically cancel any pending + events associated with the socket. Attempting to close a socket + that is not open has no effect. + Important: Transient applications (non TSRs) MUST close all their + sockets before terminating, even if the socket was opened with the + Forever flag set false. There exists a small window of time between + the program ending and IPX automatically closing the socket when a + incoming packet could arrive, causing a system crash. Also do not + call IPXCloseSocket from within an Event Service Routine.} + +function IPXEventComplete(IPXEvent : PipxEventRec; + var CompletionCode : byte) : boolean; + {-Return the status of a pending IPX event. + Notes: If this function returns true, the event's completion code + is returned in CompletionCode.} + +procedure IPXFreeEventRec(IPXEvent : PipxEventRec); + {-Free an IPX event record that was allocated by IPXAllocEventRec.} + +procedure IPXFreePacket(P : PPacket); + {-Free a data packet that was allocated by IPXAllocPacket} + +procedure IPXInternetAddress(var Address : IPXAddress); + {-Return the internetwork address of the calling workstation. + Notes: Only the network number and physical node address subfields + are returned by this function. The socket field is not returned.} + +function IPXListen(IPXEvent : PipxEventRec; + Socket : word; + WaitForCompletion : boolean; + MaxPacketSize : word; + DataPacket : PPacket) : byte; + {-Initialize the IPX event record to listen for a data packet, and + submit it to IPX. + Notes: IPXEvent must be allocated with IPXAllocEventRec. IPXListen + initializes this record and opens the socket (if not already open). + DataPacket must be allocated with IPXAllocPacket. The listen event + cannot be assumed to be complete when this function returns + (unless WaitForCompletion is true), hence the IPXEvent pointer + must remain in scope until the event does complete. Use + IPXEventComplete to check for completion of the listen event, and + the completion code.} + +function IPXOpenSocket(Socket : word; Forever : boolean) : byte; + {-Open a socket for use by IPX or SPX. + Notes: If Forever is true the socket will remain open until + explictly closed with IPXCloseSocket. If false NetWare closes the + socket when the program ends (in DOS mode only).} + +function IPXOpenUniqueSocket(var Socket : word; + Forever : boolean) : word; + {-Open and return a unique socket number. + Notes: Novell calls these dynamic sockets, their value depends on + the network loading at the time.} + +procedure IPXRelinquish; + {-Yield processing to IPX. + Notes: This procedure serves one of two purposes, depending whether + it is invoked from a non-dedicated file server or a workstation. On + a server, this function temporarily suspends the calling process so + that the server program gets CPU resources immediately. Similarly, + on a workstation, the NetWare shell gets termporary control during + which it may check for incoming and outgoing messages. + IPXRelinquish should be called frequently while an app waits for an + IPX or SPX event to complete. IPXEventComplete and SPXEventComplete + both call IPXRelinquish automatically.} + +function IPXSend(IPXEvent : PipxEventRec; + Receiver : IPXAddress; + Socket : word; + WaitForCompletion : boolean; + DataPacketSize : word; + DataPacket : PPacket) : byte; + {-Initialize the IPX event record to submit a data packet, and submit + it to IPX. + Notes: IPXEvent must be allocated with IPXAllocEventRec. IPXSend + initializes this record and opens the socket (if not already open). + The caller must initialize Receiver with a valid IPX address (except + for the socket number); to do an IPX broadcast use IPXAllNodes as + the physical node address. DataPacket must be allocated with + IPXAllocPacket. The send event cannot be assumed to be complete + when this function returns (unless WaitForCompletion is true), + hence the IPXEvent pointer must remain in scope until the event + does complete. Use IPXEventComplete to check for completion of the + send event, and the completion code.} + +function IPXServicesAvail : boolean; + {-Return true if IPX services are available} + + +{******************************************* + AES Services (Asynchronous Event Scheduler) + *******************************************} + +function AESAllocECB(ESR : AESEventServiceRoutine) : PAESECB; + {-Allocate an ECB for use with AES} + +function AESCancelEvent(ECB : PAESECB) : byte; + {-Cancel the previously scheduled AES event} + +function AESEventComplete(ECB : PAESECB) : boolean; + {-Return true if the AES scheduled event is complete} + +procedure AESFreeECB(ECB : PAESECB); + {-Free an ECB previously allocated with AESAllocECB} + +function AESScheduleEvent(DelayTicks : word; ECB : PAESECB) : byte; + {-Schedule an AES event to occur in DelayTicks time} + + +{************************************************* + SPX Services (Sequenced Packet Exchange Protocol) + *************************************************} + +procedure SPXAbortConn(SPXEvent : PspxEventRec); + {-Unilaterally abort an SPX event. + Notes: The connected partner is not informed of the break, so this + procedure should only be used in emergency. SPXTerminateConn + should normally be used.} + +function SPXAllocEventRec(NumECBs : byte; MaxPacketSize : word) : PspxEventRec; + {-Allocate an SPX event record and initialize it ready for SPX. + Notes: SPX event records passed to the SPX routines in this unit + MUST be allocated with this function, as it performs some + initialisations after allocating the event record. NumECBs should + be at least 2 and at most SPXMaxPoolCount, and will be used to + set the size of the pool of buffers actively listening for packets + to be received via this event record's connection (SPX itself + requires at most two of these buffers). MaxPacketSize is the + maximum size of the user-defined packets that are expected to be + received and must be less than SPXMaxDataSize. If the function + returns nil either heap or DOS memory is exhausted.} + +procedure SPXCancelListenForConn(SPXEvent : PspxEventRec); + {-Cancels a call to SPXListenForConn made with WaitForCompletion + set to false that hasn't completed yet.} + +function SPXECBsListening(SPXEvent : PspxEventRec) : byte; + {-Return the number of buffers listening within this event record.} + +function SPXEstablishConn(SPXEvent : PspxEventRec; + Receiver : IPXAddress; + LocalSocket : word; + RemoteSocket : word; + WaitForCompletion : boolean) : byte; + {-Attempt to establish an SPX connection with Receiver. + Notes: You must initialize Receiver with an exact IPX address, IPX + broadcasts are not allowed. LocalSocket defines the socket this + process will use to talk to SPX, RemoteSocket defines the socket + the potential partner will use; they cannot be the same. + SPXEstablishConn will open the local socket, post all the pool + ECBs to listen on that socket and then send a message to Receiver + requesting connection. If the remote partner is listening with + SPXListenForConn on the RemoteSocket he will acknowledge, and the + connection is set up. The connection number will be stored in the + internal field SPXEvent^.ConnID. Unless the WaitForCompletion flag + is true, the SPX event cannot be assumed to be complete when this + routine terminates, hence the SPXEvent must remain in scope. Use + SPXEventComplete to check for the completion of the event. If + WaitForCompletion is False, and you wish to cancel the event, use + SPXAbortConn *not* SPXTerminateConn.} + +function SPXEventComplete(SPXEvent : PspxEventRec; + var FinalResult : byte) : boolean; + {-Return the status of a pending SPX event. + Notes: If this function returns true, the event's completion code + is returned in CompletionCode.} + +procedure SPXFreeEventRec(SPXEvent : PspxEventRec); + {-Free an SPX event record allocated by SPXAllocEventRec + Notes: The connection associated with this event record must have + been terminated first, otherwise a system crash will occur.} + +function SPXGetConnStatus(SPXEvent : PspxEventRec; + var ConnStatus : TSPXStatus) : byte; + {-Return the status of the connection associated with SPXEvent} + +function SPXListenForConn(SPXEvent : PspxEventRec; + LocalSocket : word; + WaitForCompletion : boolean) : byte; + {-Listen for an SPX connection request from a remote partner + Notes: This function is the counterpart to SPXEstablishConn. For + a connection to be established between two partners, one must + be passively listening with SPXListenForConn, and the other + actively asking for connection with SPXEstablishConn. LocalSocket + is the socket that this process will use to talk to SPX (it MUST + equal RemoteSocket in SPXEstablishConn). This routine will post + all the listen buffers in the event record to listen for the + establish connection message. Unless the WaitForCompletion flag is + true, the SPX event cannot be assumed to be complete when this + routine terminates, hence the SPXEvent must remain in scope. Use + SPXEventComplete to check for the completion of the event. If + WaitForCompletion is false and you wish to cancel the event use + SPXCancelListenForConn.} + +function SPXPacketReceived(SPXEvent : PspxEventRec; + var Index : byte; + var DataType : byte; + var CompletionCode : byte; + var DataPtr : pointer) : boolean; + {-Return true if an SPX packet has been received. + Notes: Index identifies the listen buffer that received the packet + and its value should be used to repost the buffer to the pool with + SPXReactivateECB. DataType identifies the type of data received: + zero for user-defined packets or SPXEndOfConn if the remote + partner has terminated the connection (note that this routine will + mark the SPXEvent accordingly). CompletionCode will be one of + 0, IPXCancelled, IPXMalformedPacket, IPXPacketOverflow, + IPXPhysicalError or SPXFailedConn. DataPtr is set to point to the + received data in the listen buffer. Ideally if this routine returns + true the application should copy the data to a local buffer, and + resubmit the listen buffer to the pool as soon as possible.} + +procedure SPXReactivateECB(SPXEvent : PspxEventRec; + Index : byte); + {-Resubmit an buffer to the listen pool} + +function SPXSend(SPXEvent : PspxEventRec; + WaitForCompletion : boolean; + DataPacketSize : word; + DataPacket : PPacket) : byte; + {-Send a data packet using SPX services + Notes: The connection must be completely initialized prior to + calling this routine (ie the establish or listen for connection + event should have completed successfully). DataPacket must be + allocated with IPXAllocPacket. This function will then set up + the event record to send the packet, and submit the request to + SPX. Unless WaitForCompletion is true, the event cannot be assumed + complete when this routine terminates, use SPXEventComplete to + check for completion of the event.} + +function SPXServicesAvail(var Version : word; + var MaxSPXConn : word; + var AvailSPXConn : word) : boolean; + {-Return true if SPX services are available} + +procedure SPXTerminateConn(SPXEvent : PspxEventRec); + {-Terminate an existing SPX connection + Notes: When this routine returns the connection has been broken + and the SPXEvent record can be reused to establish another + connection or freed.} + +implementation + +type + LH = record L, H : word; end; {decompose a nwLong into 2 words} + OS = record O, S : word; end; {decompose a pointer into seg/sel and ofs} + +type + TargetType = record {used by IPXGetLocalTarget} + IPXAdd : IPXAddress; + TargetNode : PhysicalNodeAddress; + end; + +const + IPXServicesAvailable : boolean = false; + +var + IPXLocation : pointer; {IPX realmode entry point address} + +{$IFDEF DPMIorWnd} +{---The DPMI IPX event service routine variables---} +var + IPXEventHandlerRegs : DPMIRegisters; + IPXCallBack : pointer; +const + IPXRecList : PipxEventRec = nil; {the linked list of IPXRecs} + +{---The DPMI AES event service routine variables---} +var + AESEventHandlerRegs : DPMIRegisters; + AESCallBack : pointer; +const + AESECBList : PAESECB = nil; {the linked list of AESECBs} + +{---The DPMI SPX event service routine variables---} +var + SPXEventHandlerRegs : DPMIRegisters; + SPXCallBack : pointer; +{$ENDIF} + +const + SPXRecList : PspxEventRec = nil; {the linked list of SPXRecs} + + +{Note: to isolate the different usage of packets in protected mode +programming and in real-mode programming (basically we *must* have a +DOS memory block in protected mode, and it's the real-mode pointer +to the block that is passed to IPX/SPX), IPXAllocPacket will +return the address of a block of memory that follows directly on from +an 8 byte block of the form TPacketInfo. By this 'trick' we can ensure +packets (or datagrams) passed to the relevant IPX/SPX routines in +protected mode have been properly allocated, that we can get the real +mode pointer easily for a pmode block, and also that the code for +calling these routines is the same in real-mode and protected mode.} +type + PPacketInfo = ^TPacketInfo; + TPacketInfo = record {THIS MUST BE EIGHT (8) BYTES} + Sig : word; {Always 'PI' back-words} + RealPtr : pointer; {DPMI real-mode pointer to data} + DSize : word; {size of data block} + end; +const + PacketSig = $4950; {'PI' back-words} + +{$IFDEF DPMIorWnd} +function DOSGetMem(var RealPtr, ProtPtr; Size : word) : boolean; near; + {Get a block of DOS memory and return real and protected pointers} + var + RealMode : pointer absolute RealPtr; + ProtMode : pointer absolute ProtPtr; + AllocResult : longint; + begin + AllocResult := GlobalDOSAlloc(Size); + if (AllocResult <> 0) then + begin + RealMode := Ptr(LH(AllocResult).H, 0); + ProtMode := Ptr(LH(AllocResult).L, 0); + DOSGetMem := true; + end + else DOSGetMem := false; + end; + +procedure DOSFreeMem(ProtPtr : pointer); near; + {Free a block of DOS memory} + var + Dummy : word; + begin + Dummy := GlobalDOSFree(OS(ProtPtr).S); + end; +{$ENDIF} + +function GetRealModePtr(Packet : PPacket) : pointer; + {-Returns the real mode pointer for Packet. In pmode this code + assumes that IsAnotherPacketType has been called and it + returned false.} + {$IFDEF DPMIorWnd} + assembler; + asm + les bx, Packet + sub bx, 6 + mov ax, es:[bx] + mov dx, es:[bx+2] + end; + {$ELSE} + inline($58/$5A); {pop ax; pop dx} + {$ENDIF} + +function IsAnotherPacketType(Packet : PPacket) : boolean; + {-Returns true if Packet was *not* allocated by IPXAllocPacket} + assembler; + asm + mov ax, 1 {assume true, ie it's not ours} + mov bx, Packet.word[0] {get offset} + sub bx, 8 {subtract sizeof(TPacketInfo)} + jl @@Exit {if negative not ours, so exit} + mov es, Packet.word[2] {get segment/selector} + cmp word ptr es:[bx], PacketSig {1st word should be signature} + jne @@Exit {no, so not ours} + xor ax, ax {it's our type, return false} + @@Exit: + end; + +procedure DisableInterrupts; + {-Disable hardware interrupts} + {$IFDEF DPMIorWnd} + inline($B8/$00/$09/ {mov ax, $0900} + $CD/$31/ {int $31} + $B8/$81/$16/ {mov ax, $1681} + $CD/$2F); {int $2F} + {$ELSE} + inline($FA); + {$ENDIF} + +procedure EnableInterrupts; + {-Reenable hardware interrupts} + {$IFDEF DPMIorWnd} + inline($B8/$01/$09/ {mov ax, $0901} + $CD/$31/ {int $31} + $B8/$82/$16/ {mov ax, $1682} + $CD/$2F); {int $2F} + {$ELSE} + inline($FB); + {$ENDIF} + + +{**************************************************** + IPX Services (Internetwork Packet Exchange Protocol) + ****************************************************} + +{$IFDEF DPMIorWnd} +procedure IPXEventHandler(FromAES : boolean; RealModePtr : nwLong); + {-The DPMI IPX event handler. Works out which ECB was returned for + processing by IPX and calls its event handler.} + var + IPXEvent : PipxEventRec; + StillLooking : boolean; + R : pointer; + begin + IPXEvent := IPXRecList; + StillLooking := true; + while StillLooking and (IPXEvent <> nil) do + if (nwLong(GetRealModePtr(IPXEvent)) <> RealModePtr) then + IPXEvent := IPXEvent^.Next + else {We've found the relevant IPX event record} + begin + StillLooking := false; + {call the user's ESR} + IPXEvent^.UserESR(FromAES, IPXEvent); + end; + end; + +procedure IPXCallbackShell; far; assembler; + asm + {Note: this uses the same processing as SPXCallBackShell. See that + routine for comments.} + mov ax, 1681h + int 2Fh + push es; push di + cld + lodsw; mov es:[di].DPMIRegisters.&IP, ax + lodsw; mov es:[di].DPMIRegisters.&CS, ax + add es:[di].DPMIRegisters.&SP, 4 + push word ptr es:[di].DPMIRegisters.&AX.word[0] + push word ptr es:[di].DPMIRegisters.&ES + push word ptr es:[di].DPMIRegisters.&SI.word[0] + mov ax, es + mov ds, ax + call IPXEventHandler + pop di; pop es + mov ax,1682h + int 2Fh + iret + end; + +function IPXAllocateDPMIESR : boolean; + begin + IPXAllocateDPMIESR := + AllocRealModeCallBackAddr(@IPXCallBackShell, + IPXEventHandlerRegs, + IPXCallBack) = 0; + end; + +procedure IPXFreeDPMIESR; + var + Dummy : word; + begin + Dummy := FreeRealModeCallBackAddr(IPXCallBack); + end; +{$ELSE} +procedure IPXESRDispatch; far; assembler; + asm + inc ax {al=$FF => IPX, al=0 => AES} + push ax + mov ax, SEG @Data + mov ds, ax + push es + push si + call dword ptr es:[si].TipxEventRec.UserESR + end; +{$ENDIF} + +{===Packet allocation and deallocation===} +function IPXAllocPacket(Size : word) : PPacket; + var + P : PPacketInfo; + R : pointer; + begin + {$IFDEF DPMIorWnd} + if DOSGetMem(R, P, Size+sizeof(TPacketInfo)) then + begin + with P^ do + begin + Sig := PacketSig; + RealPtr := R; + inc(OS(RealPtr).O, sizeof(TPacketInfo)); + DSize := Size; + end; + inc(OS(P).O, sizeof(TPacketInfo)); + end + else P := nil; + {$ELSE} + if nwGetMem(P, Size+sizeof(TPacketInfo)) then + begin + with P^ do + begin + Sig := PacketSig; + RealPtr := P; + inc(OS(RealPtr).O, sizeof(TPacketInfo)); + DSize := Size; + end; + P := P^.RealPtr; + end; + {$ENDIF} + IPXAllocPacket := PPacket(P); + end; +{--------} +procedure IPXFreePacket(P : PPacket); + var + Size : word; + TempP : PPacketInfo; + begin + if not IsAnotherPacketType(P) then + begin + TempP := P; + dec(OS(TempP).O, sizeof(TPacketInfo)); + Size := TempP^.DSize+sizeof(TPacketInfo); + {trash the memory block to ensure that it cannot inadvertently + be used again without reallocation, $CC is INT 3} + FillChar(TempP^, Size, $CC); + {$IFDEF DPMIorWnd} + DOSFreeMem(TempP); + {$ELSE} + FreeMem(TempP, Size); + {$ENDIF} + end; + end; + + +{===IPX Event record allocation and deallocation===} +function IPXAllocEventRec(ESR : IPXEventServiceRoutine) : PipxEventRec; + var + P : PipxEventRec; + begin + P := PipxEventRec(IPXAllocPacket(sizeof(TipxEventRec))); + if (P <> nil) then + with P^ do + begin + {zeroize the entire record (incl ESRAddress), and set the + user's ESR field} + FillChar(P^, sizeof(TipxEventRec), 0); + UserESR := ESR; + {$IFDEF DPMIorWnd} + if IPXRecList = nil then + if not IPXAllocateDPMIESR then + begin + IPXFreePacket(PPacket(P)); + IPXAllocEventRec := nil; + Exit; + end; + Next := IPXRecList; + IPXRecList := P; + {If there is an actual ESR, set the ESRAddress field so that + IPX can call us via the call back} + if (@ESR <> nil) then + ECB.ESRAddress := IPXCallBack; + {$ELSE} + {If there is an actual ESR, set the ESRAddress field so that + IPX can call us via the dispatcher} + if (@ESR <> nil) then + ECB.ESRAddress := @IPXESRDispatch; + {$ENDIF} + end; + IPXAllocEventRec := P; + end; +{--------} +procedure IPXFreeEventRec(IPXEvent : PipxEventRec); + var + Temp, Dad : PipxEventRec; + begin + {$IFDEF DPMIorWnd} + Temp := IPXRecList; + Dad := nil; + while (Temp <> nil) and (Temp <> IPXEvent) do + begin + Dad := Temp; + Temp := Temp^.Next; + end; + if (Temp <> nil) then + if (Dad = nil) then + begin + IPXRecList := Temp^.Next; + if (IPXRecList = nil) then + IPXFreeDPMIESR; + end + else + Dad^.Next := Temp^.Next; + {$ENDIF} + {free the IPXEvent as a packet} + IPXFreePacket(PPacket(IPXEvent)); + end; + + +{===Primitive routines to call IPX===} +function IPXCall(var Regs : TnwRegisters) : byte; near; + {-Calls the real mode IPX driver at IPXLocation} +{$IFDEF DPMIorWnd} + var + DPMIRegs : DPMIRegisters absolute Regs; + Dummy : word; + begin + with Regs do begin + CS := OS(IPXLocation).S; + IP := OS(IPXLocation).O; + end; + if (CallFarRealModeProc(0, nil, DPMIRegs) <> 0) then + IPXCall := IPXErrDPMIError + else + IPXCall := Regs.AL; + end; +{$ELSE} + assembler; + var + ipxEntryPoint : pointer; + asm + {Notes: the Regs.BP field and BP register are not set/restored as + IPX can internally use it as a scratch register.} + mov ax, IPXLocation.word[2] + mov ipxEntryPoint.word[2], ax + mov ax, IPXLocation.word[0] + mov ipxEntryPoint.word[0], ax + push ds {save our data segment} + push bp {...and our stack frame} + + lds si, Regs {Set up the registers...} + mov ax, [si].TnwRegisters.&SI + push ax + mov ax, [si].TnwRegisters.&DS + push ax + mov di, [si].TnwRegisters.&DI + mov bx, [si].TnwRegisters.&BX + mov dx, [si].TnwRegisters.&DX + mov cx, [si].TnwRegisters.&CX + mov ax, [si].TnwRegisters.&AX + mov es, [si].TnwRegisters.&ES + pop ds + pop si + + call ipxEntryPoint {call IPX} + pop bp {discard returned BP & restore our stack frame} + push ax {push the call result} + push ds {Set up the Regs variable} + pushf + push si + + lds si, Regs + mov [si].TnwRegisters.&DI, di + mov [si].TnwRegisters.&BX, bx + mov [si].TnwRegisters.&DX, dx + mov [si].TnwRegisters.&CX, cx + mov [si].TnwRegisters.&AX, ax + mov [si].TnwRegisters.&ES, es + pop ax + mov [si].TnwRegisters.&SI, ax + pop ax + mov [si].TnwRegisters.&Flags, ax + pop ax + mov [si].TnwRegisters.&DS, ax + + pop ax {get the call result} + pop ds {restore Pascal's DS} + @@Exit: + end; +{$ENDIF} +{--------} +function IPXCallWithECB(Func : word; ECB : PipxECB) : byte; near; + {-Primitive to call IPX with an ECB. + Notes: in pmode ECB is a realmode pointer} + var + Regs : TnwRegisters; + begin + nwInitRegs(Regs); + with Regs do + begin + BX := Func; + ES := OS(ECB).S; + SI := OS(ECB).O; + end; + IPXCallWithECB := IPXCall(Regs); + end; + +{===Utiltity routines for IPX===} +function IPXInstalled : boolean; near; + {-Checks for presence of IPX and sets the driver entry address IPXLocation} + var + IntrResult : word; + Regs : TnwRegisters; + begin + {Assume IPX not found} + IPXInstalled := false; + IPXLocation := nil; + nwInitRegs(Regs); + Regs.AX := $7A00; + IntrResult := nwIntr($2F, Regs); + if (IntrResult = 0) and (Regs.AL = $FF) then + begin + IPXInstalled := true; + IPXLocation := Ptr(Regs.ES, Regs.DI); {pointer to IPX entry point in ES:DI} + end; + end; +{--------} +procedure InitializeIPX; + {-Initializes the IPX/SPX variables - called by unit initialisation} + begin + if IPXInstalled then {this call to IPXInstalled also sets IPXlocation} + IPXServicesAvailable := true; + end; +{--------} +function IPXServicesAvail : boolean; + begin + IPXServicesAvail := IPXServicesAvailable; + end; +{--------} +procedure IPXInternetAddress(var Address : IPXAddress); + var + Regs : TnwRegisters; + Dummy : byte; + begin + FillChar(nwGlobalBuf^, SizeOf(IPXAddress), 0); + nwInitRegs(Regs); + with Regs do + begin + BX := $09; + ES := OS(nwGlobalBufRealPtr).S; + SI := OS(nwGlobalBufRealPtr).O; + end; + Dummy := IPXCall(Regs); + Move(nwGlobalBuf^, Address, SizeOf(IPXAddress)); + end; +{--------} +function IPXGetLocalTarget(var LocalTarget : TargetType; + var TransportTime : word) : byte; + var + Regs : TnwRegisters; + CallResult : byte; + begin + Move(LocalTarget, nwGlobalBuf^, SizeOf(TargetType)); + nwInitRegs(Regs); + with Regs do + begin + BX := $02; + ES := OS(nwGlobalBufRealPtr).S; + SI := OS(nwGlobalBufRealPtr).O; + DI := SI + sizeof(IPXAddress); + end; + CallResult := IPXCall(Regs); + if (CallResult = 0) then + begin + TransportTime := Regs.CX; + Move(nwGlobalBuf^, LocalTarget, SizeOf(TargetType)); + end; + IPXGetLocalTarget := CallResult; + end; + + +{===Socket access===} +function IPXOpenSocket(Socket : word; Forever : boolean) : byte; + {-Open a socket} + var + Regs : TnwRegisters; + begin + nwInitRegs(Regs); + if Forever then + Regs.AX := $FF; + Regs.DX := Swap(Socket); + IPXOpenSocket := IPXCall(Regs); + end; +{--------} +function IPXOpenUniqueSocket(var Socket : word; Forever : boolean) : word; + {-Open a dynamic socket and return it} + var + Regs : TnwRegisters; + CallResult : byte; + begin + nwInitRegs(Regs); + if Forever then + Regs.AX := $FF; + CallResult := IPXCall(Regs); + if (CallResult = 0) then + Socket := Swap(Regs.DX); + IPXOpenUniqueSocket := CallResult; + end; +{--------} +procedure IPXCloseSocket(Socket : word); + {-Close a socket} + var + Regs : TnwRegisters; + Dummy : byte; + begin + nwInitRegs(Regs); + Regs.BX := 1; + Regs.DX := Swap(Socket); + Dummy := IPXCall(Regs); + end; + +{===IPX Communication routines===} +function IPXEventComplete(IPXEvent : PipxEventRec; + var CompletionCode : byte) : boolean; + begin + with IPXEvent^ do + begin + IPXRelinquish; + if (ECB.InUse = 0) then + begin + IPXEventComplete := true; + CompletionCode := ECB.CompletionCode; + end + else + IPXEventComplete := false; + end; + end; +{--------} +procedure IPXRelinquish; + var + Regs : TnwRegisters; + Dummy : byte; + begin + nwInitRegs(Regs); + Regs.BX := $0A; + Dummy := IPXCall(Regs); + end; +{--------} +function IPXSend(IPXEvent : PipxEventRec; + Receiver : IPXAddress; + Socket : word; + WaitForCompletion : boolean; + DataPacketSize : word; + DataPacket : PPacket) : byte; + var + TransportTime : word; + ActualTarget : TargetType; + CallResult : byte; + begin + CallResult := 0; + {check that the DataPacket is valid} + if IsAnotherPacketType(DataPacket) then + CallResult := IPXErrBadPacket + {check the size of the data passed to make sure it is not too big} + else if (DataPacketSize > IPXMaxDataSize) then + CallResult := IPXErrDataTooLarge + {check that the event record is one of ours} + else if IsAnotherPacketType(IPXEvent) then + CallResult := IPXErrBadEventRec; + {open the socket} + if (CallResult = 0) then + begin + CallResult := IPXOpenSocket(Socket, false); + if (CallResult = IPXErrSocketAlreadyOpen) then + CallResult := 0; + end; + {exit if there's a problem so far} + if (CallResult <> 0) then + begin + IPXSend := CallResult; + Exit; + end; + {do the work} + with IPXEvent^, ECB, Header do + begin + {Set the fields in the ECB} + InUse := 0; + SocketNumber := Swap(Socket); + {the high level IPX routines always use two buffer fragments. FD1 + points to the IPX header, and FD2 points to the user data.} + FragmentCount := 2; + with FD1 do + begin {point FD1 to the TipxHeader} + Data := GetRealModePtr(IPXEvent); + inc(OS(Data).O, sizeof(TipxECB)); + Size := SizeOf(TipxHeader); + end; + with FD2 do + begin {point FD2 to the user data} + Data := GetRealModePtr(DataPacket); + Size := DataPacketSize; + end; + {init the ImmediateAddress} + Move(Receiver, ActualTarget, SizeOf(IPXAddress)); + if IPXGetLocalTarget(ActualTarget, TransportTime) <> 0 then + Move(Receiver.Node, ActualTarget.TargetNode, + SizeOf(ActualTarget.TargetNode)); + Move(ActualTarget.TargetNode,ImmediateAddress, + SizeOf(PhysicalNodeAddress)); + {init the IPX Header} + PacketType := 4; {4 = Packet Exchange Packet} + {init the Destination record with Network, node and socket info} + Destination.Network := Receiver.Network; + Destination.Node := Receiver.Node; + Destination.Socket := Swap(Socket); + {Get IPX to do the sending} + CallResult := IPXCallWithECB(3, GetRealModePtr(IPXEvent)); + if (CallResult = 0) and WaitForCompletion then + repeat until IPXEventComplete(IPXEvent, CallResult); + IPXSend := CallResult; + end; + end; + +function IPXListen(IPXEvent : PipxEventRec; + Socket : word; + WaitForCompletion : boolean; + MaxPacketSize : word; + DataPacket : PPacket) : byte; + var + CallResult : byte; + begin + CallResult := 0; + {check that the DataPacket is valid} + if IsAnotherPacketType(DataPacket) then + CallResult := IPXErrBadPacket + {check the size of the data passed to make sure it is not too big} + else if (MaxPacketSize > IPXMaxDataSize) then + CallResult := IPXErrDataTooLarge + {check that the event record is one of ours} + else if IsAnotherPacketType(IPXEvent) then + CallResult := IPXErrBadEventRec; + {open the socket} + if (CallResult = 0) then + begin + CallResult := IPXOpenSocket(Socket, false); + if (CallResult = IPXErrSocketAlreadyOpen) then + CallResult := 0; + end; + {exit if there's a problem so far} + if (CallResult <> 0) then + begin + IPXListen := CallResult; + Exit; + end; + {do the work} + with IPXEvent^, ECB do + begin + {Set the fields in the ECB} + InUse := 0; + SocketNumber := Swap(Socket); + {the high level IPX routines always use two buffer fragments. FD1 + points to the IPX header, and FD2 points to the user data.} + FragmentCount := 2; + with FD1 do + begin {point FD1 to the TipxHeader} + Data := GetRealModePtr(IPXEvent); + inc(OS(Data).O, sizeof(TipxECB)); + Size := SizeOf(TipxHeader); + end; + with FD2 do + begin {point FD2 to the user data} + Data := GetRealModePtr(DataPacket); + Size := MaxPacketSize; + end; + {Get IPX to listen in} + CallResult := IPXCallWithECB(4, GetRealModePtr(IPXEvent)); + if (CallResult = 0) and WaitForCompletion then + repeat until IPXEventComplete(IPXEvent, CallResult); + IPXListen := CallResult; + end; + end; +{--------} +function IPXCancelEvent(IPXEvent : PipxEventRec) : byte; + var + CancelResult : byte; + begin + if IsAnotherPacketType(IPXEvent) then + IPXCancelEvent := IPXErrBadEventRec + else + begin + CancelResult := IPXCallWithECB(6, GetRealModePtr(IPXEvent)); + {zero out the ECB: recommendation by Steve Meyer (Avanti)} + if (CancelResult = 0) then + FillChar(IPXEvent^.ECB, sizeof(TipxECB), 0); + IPXCancelEvent := CancelResult; + end; + end; + + +{******************************************* + AES Services (Asynchronous Event Scheduler) + *******************************************} + +{$IFDEF DPMIorWnd} +procedure AESEventHandler(RealModePtr : nwLong); + {-The DPMI AES event handler. Works out which ECB was returned for + processing by AES and calls its event handler.} + var + ECB : PAESECB; + StillLooking : boolean; + R : pointer; + begin + ECB := AESECBList; + StillLooking := true; + while StillLooking and (ECB <> nil) do + if (nwLong(GetRealModePtr(ECB)) <> RealModePtr) then + ECB := ECB^.Next + else {We've found the relevant AES ECB} + begin + StillLooking := false; + {call the user's ESR} + ECB^.UserESR(ECB); + end; + end; + +procedure AESCallbackShell; far; assembler; + asm + {Note: this uses the same processing as SPXCallBackShell. See that + routine for comments.} + mov ax, 1681h + int 2Fh + push es; push di + cld + lodsw; mov es:[di].DPMIRegisters.&IP, ax + lodsw; mov es:[di].DPMIRegisters.&CS, ax + add es:[di].DPMIRegisters.&SP, 4 + push word ptr es:[di].DPMIRegisters.&ES + push word ptr es:[di].DPMIRegisters.&SI.word[0] + mov ax, es + mov ds, ax + call AESEventHandler + pop di; pop es + mov ax,1682h + int 2Fh + iret + end; + +function AESAllocateDPMIESR : boolean; + begin + AESAllocateDPMIESR := + AllocRealModeCallBackAddr(@AESCallBackShell, + AESEventHandlerRegs, + AESCallBack) = 0; + end; + +procedure AESFreeDPMIESR; + var + Dummy : word; + begin + Dummy := FreeRealModeCallBackAddr(AESCallBack); + end; +{$ELSE} +procedure AESESRDispatch; far; assembler; + asm + mov ax, SEG @Data + mov ds, ax + push es + push si + call dword ptr es:[si].TAESECB.UserESR + end; +{$ENDIF} + +function AESAllocECB(ESR : AESEventServiceRoutine) : PAESECB; + var + P : PAESECB; + begin + P := PAESECB(IPXAllocPacket(sizeof(TAESECB))); + if (P <> nil) then + with P^ do + begin + {zeroize the entire record (incl ESRAddress), and set the + user's ESR field} + FillChar(P^, sizeof(TAESECB), 0); + UserESR := ESR; + {$IFDEF DPMIorWnd} + if AESECBList = nil then + if not AESAllocateDPMIESR then + begin + IPXFreePacket(PPacket(P)); + AESAllocECB := nil; + Exit; + end; + Next := AESECBList; + AESECBList := P; + {If there is an actual ESR, set the ESRAddress field so that + AES can call us via the call back} + if (@ESR <> nil) then + ESRAddress := AESCallBack; + {$ELSE} + {If there is an actual ESR, set the ESRAddress field so that + AES can call us via the AES dispatcher} + if (@ESR <> nil) then + ESRAddress := @AESESRDispatch; + {$ENDIF} + end; + AESAllocECB := P; + end; + +function AESCancelEvent(ECB : PAESECB) : byte; + begin + if IsAnotherPacketType(ECB) then + AESCancelEvent := AESErrBadECB + else + AESCancelEvent := IPXCallWithECB(6, GetRealModePtr(ECB)); + end; + +function AESEventComplete(ECB : PAESECB) : boolean; + begin + IPXRelinquish; + AESEventComplete := (ECB^.InUse = 0); + end; + +procedure AESFreeECB(ECB : PAESECB); + var + Temp, Dad : PAESECB; + begin + {$IFDEF DPMIorWnd} + Temp := AESECBList; + Dad := nil; + while (Temp <> nil) and (Temp <> ECB) do + begin + Dad := Temp; + Temp := Temp^.Next; + end; + if (Temp <> nil) then + if (Dad = nil) then + begin + AESECBList := Temp^.Next; + if (AESECBList = nil) then + AESFreeDPMIESR; + end + else + Dad^.Next := Temp^.Next; + {$ENDIF} + {free the ECB as a packet} + IPXFreePacket(PPacket(ECB)); + end; + +function AESScheduleEvent(DelayTicks : word; ECB : PAESECB) : byte; + var + Regs : TnwRegisters; + RealECB : pointer; + begin + if IsAnotherPacketType(ECB) then + AESScheduleEvent := AESErrBadECB + else + begin + RealECB := GetRealModePtr(ECB); + nwInitRegs(Regs); + with Regs do + begin + BX := $07; + AX := DelayTicks; + ES := OS(RealECB).S; + SI := OS(RealECB).O; + end; + AESScheduleEvent := IPXCall(Regs); + end; + end; + + +{************************************************* + SPX Services (Sequenced Packet Exchange Protocol) + *************************************************} + +{===Handy routines===} +procedure SPXEventHandler(RealModeSeg, RealModeOfs : word); far; + {-The listen pool event handler. Works out which ECB was returned for + processing by SPX and places it in the pool queue to be processed. + WARNING: this routine's code assumes that the segment/selector value + will be different for each PspxEventRec. In pmode this means that + GlobalDOSAlloc must provide different selector values for each + allocation (it does as the offset is assumed 0) and in real mode that + GetMem gives you a different segment value for each allocation (it does + for TP6 and BP7: the pointers are always normalised with offsets 0 or + 8).} + var + SPXEvent : PspxEventRec; + StillLooking : boolean; + R : pointer; + Index : integer; + begin + SPXEvent := SPXRecList; + StillLooking := true; + while StillLooking and (SPXEvent <> nil) do + begin + R := GetRealModePtr(SPXEvent); + if (OS(R).S <> RealModeSeg) then + SPXEvent := SPXEvent^.Next + else {We've found the relevant SPX event record} + begin + Index := 1; + with SPXEvent^ do + while StillLooking do + if (OS(Pool[Index]).O <> RealModeOfs) then + begin + inc(Index); + if (Index > PoolCount) then + StillLooking := false; + end + else + begin + StillLooking := false; + {Note: interrupts are disabled so we can alter + the queue with impunity} + inc(QueueCount); + Queue[QueueCount] := Index; + end; + end; + end; + end; +{--------} +{$IFDEF DPMIorWnd} +procedure SPXCallbackShell; far; assembler; + asm + {WARNING - this assumes that the DPMI registers structure is a + global variable. SPXEventHandlerRegs certainly is.} + + {Entering a critical section} + mov ax, 1681h + int 2Fh + { ES:DI points to the DPMI register structure } + { DS:SI points to the real mode's SS:SP } + {Save the DPMI register structure for returning to real-mode} + push es; push di + {Set up the return registers} + cld + lodsw; mov es:[di].DPMIRegisters.&IP, ax + lodsw; mov es:[di].DPMIRegisters.&CS, ax + add es:[di].DPMIRegisters.&SP, 4 + {Set things up for SPXEventHandler} + push word ptr es:[di].DPMIRegisters.&ES + push word ptr es:[di].DPMIRegisters.&SI.word[0] + mov ax, es + mov ds, ax + call SPXEventHandler + {Get the return DPMI register structure} + pop di; pop es + {Leaving critical section} + mov ax,1682h + int 2Fh + iret + end; +{--------} +function SPXAllocateDPMIESR : boolean; + begin + SPXAllocateDPMIESR := + AllocRealModeCallBackAddr(@SPXCallBackShell, + SPXEventHandlerRegs, + SPXCallBack) = 0; + end; +{--------} +procedure SPXFreeDPMIESR; + var + Dummy : word; + begin + Dummy := FreeRealModeCallBackAddr(SPXCallBack); + end; +{$ELSE} +procedure SPXCallBack; far; assembler; + {-A stub for SPX to call SPXEventHandler} + asm + mov ax, SEG @Data + mov ds, ax + push es + push si + call SPXEventHandler + end; +{$ENDIF} +{--------} +function GetRealModePoolECBPtr(SPXEvent : PspxEventRec; Index : byte) : pointer; + {-Returns the real mode pointer to the Index'th listen pool ECB in + SPXEvent - equivalent to a real mode pointer to the pool record + itself.} + {$IFDEF DPMIorWnd} + var + R : pointer; + ECB : pointer; + begin + R := GetRealModePtr(SPXEvent); + ECB := SPXEvent^.Pool[Index]; {the ECB is the first field} + GetRealModePoolECBPtr := Ptr(OS(R).S, OS(ECB).O); + end; + {$ELSE} + begin + GetRealModePoolECBPtr := SPXEvent^.Pool[Index]; {the ECB is the first field} + end; + {$ENDIF} +{--------} +procedure SPXClearOnDisconnect(SPXEvent : PspxEventRec); + {-Clears the Header and ECB, the pool records and closes the socket + when clearing a connection} + var + PoolIndex : word; + Socket : word; + begin + with SPXEvent^ do + begin + Socket := Swap(ECB.SocketNumber); + IPXCloseSocket(Socket); + FillChar(ECB, sizeof(TipxECB), 0); + FillChar(Header, sizeof(TspxHeader), 0); + AmConnected := false; + ConnID := 0; + QueueCount := 0; + for PoolIndex := 1 to PoolCount do + with Pool[PoolIndex]^ do + begin + with PoolECB do + FillChar(InUse, + sizeof(InUse)+sizeof(CompletionCode)+ + sizeof(SocketNumber)+sizeof(IPXWorkSpace)+ + sizeof(DriverWorkSpace)+sizeof(ImmediateAddress), + 0); + FillChar(PoolHeader, sizeof(TspxHeader), 0); + end; + end; + end; + + +{===Primary routines===} +function SPXEstablishConnPrim(RetryCount : byte; WatchDog : boolean; + ECB : PipxECB; + var AssignedConn : word) : byte; + {Note: in pmode ECB is a real-mode pointer} + var + Regs : TnwRegisters; + CallResult : byte; + begin + nwInitRegs(Regs); + with Regs do + begin + BX := $11; + AX := (word(WatchDog) shl 8) + RetryCount; + ES := OS(ECB).S; + SI := OS(ECB).O; + end; + CallResult := IPXCall(Regs); + if (CallResult = 0) then + AssignedConn := Regs.DX; + SPXEstablishConnPrim := CallResult; + end; +{--------} +procedure SPXListenForConnPrim(Retry : byte; WatchDog : boolean; + ECB : PipxECB); + {Note: in pmode ECB is a real-mode pointer} + var + Regs : TnwRegisters; + Dummy : byte; + begin + nwInitRegs(Regs); + with Regs do + begin + BX := $12; + AX := (word(WatchDog) shl 8) + Retry; + ES := OS(ECB).S; + SI := OS(ECB).O; + end; + Dummy := IPXCall(Regs); + end; +{--------} +procedure SPXTerminateConnPrim(ConnID : word; + ECB : PipxECB); + {Note: in pmode ECB is a real-mode pointer} + var + Regs : TnwRegisters; + Dummy : byte; + begin + nwInitRegs(Regs); + with Regs do + begin + BX := $13; + DX := ConnID; + ES := OS(ECB).S; + SI := OS(ECB).O; + end; + Dummy := IPXCall(Regs); + end; +{--------} +procedure SPXAbortConnPrim(ConnID : word); + var + Regs : TnwRegisters; + Dummy : byte; + begin + nwInitRegs(Regs); + with Regs do + begin + BX := $14; + DX := ConnID; + end; + Dummy := IPXCall(Regs); + end; +{--------} +procedure SPXSendPrim(ConnID : word; ECB : PipxECB); + var + Regs : TnwRegisters; + Dummy : byte; + begin + nwInitRegs(Regs); + with Regs do + begin + BX := $16; + DX := ConnID; + ES := OS(ECB).S; + SI := OS(ECB).O; + end; + Dummy := IPXCall(Regs); + end; +{--------} +procedure SPXListenPrim(ECB : PipxECB); + var + Regs : TnwRegisters; + Dummy : byte; + begin + nwInitRegs(Regs); + with Regs do + begin + BX := $17; + ES := OS(ECB).S; + SI := OS(ECB).O; + end; + Dummy := IPXCall(Regs); + end; + + +{===Utiltity SPX routines===} +function SPXServicesAvail(var Version : word; + var MaxSPXConn : word; + var AvailSPXConn : word) : boolean; + var + Regs : TnwRegisters; + CallResult : byte; + begin + SPXServicesAvail := false; + if IPXServicesAvailable then + begin + nwInitRegs(Regs); + with Regs do + begin + BX := $10; + CallResult := IPXCall(Regs); + if (CallResult = $FF) then + begin + Version := BX; + MaxSPXConn := CX; + AvailSPXConn := DX; + SPXServicesAvail := true; + end; + end; + end; + end; +{--------} +function SPXEventComplete(SPXEvent : PspxEventRec; + var FinalResult : byte) : boolean; + {-Note: should be used only for SPXSend, SPXEstablishConn and + SPXListenForConn type events.} + begin + if IsAnotherPacketType(SPXEvent) then + begin + SPXEventComplete := true; + FinalResult := SPXErrBadEventRec; + end + else + with SPXEvent^, ECB do + begin + IPXRelinquish; + if (InUse = 0) then + begin + SPXEventComplete := true; + FinalResult := CompletionCode; + if (not AmConnected) and (FinalResult = 0) then + begin + ConnID := word(ECB.IPXWorkSpace); + AmConnected := true; + end; + if (FinalResult = SPXErrFailedConn) or + (FinalResult = SPXErrRemoteEndedConn) then + begin + SPXClearOnDisconnect(SPXEvent); + end; + end + else + SPXEventComplete := false; + end; + end; +{--------} +function SPXGetConnStatus(SPXEvent : PspxEventRec; + var ConnStatus : TSPXStatus) : byte; + var + Regs : TnwRegisters; + CallResult : byte; + begin + if IsAnotherPacketType(SPXEvent) then + SPXGetConnStatus := SPXErrBadEventRec + else + begin + FillChar(nwGlobalBuf^, sizeof(TSPXStatus), 0); + nwInitRegs(Regs); + with Regs do + begin + BX := $15; + DX := SPXEvent^.ConnID; + ES := OS(nwGlobalBufRealPtr).S; + SI := OS(nwGlobalBufRealPtr).O; + end; + CallResult := IPXCall(Regs); + if (CallResult = 0) then + begin + Move(nwGlobalBuf^, ConnStatus, sizeof(TSPXStatus)); + with ConnStatus do + begin + SourceConn := Swap(SourceConn); + DestConn := Swap(DestConn); + SequenceNum := Swap(SequenceNum); + AckNum := Swap(AckNum); + AllocNum := Swap(AllocNum); + RemoteAckNum := Swap(RemoteAckNum); + RemoteAllocNum := Swap(RemoteAllocNum); + ConnSocket := Swap(ConnSocket); + RetransmitCount := Swap(RetransmitCount); + EstimatedRoundTripDelay := Swap(EstimatedRoundTripDelay); + RetransmittedPackets := Swap(RetransmittedPackets); + SuppressedPackets := Swap(SuppressedPackets); + end; + end; + SPXGetConnStatus := CallResult; + end; + end; + + +{===SPX Event records allocation and deallocation===} +function SPXAllocEventRec(NumECBs : byte; MaxPacketSize : word) : PspxEventRec; + var + PoolRecSize : word; + Size : word; + Count : word; + R : pointer; + P : pointer; + SPXEvent : PspxEventRec; + begin + {This routine attempts to allocate the Event record as one block + and then splits it up into ECBs and data packets. The splitting + process imposes the following data layout for the block: + SPXRec + Pool[1] + Pool[2] + ... + Pool[NumECBs] + Each Pool[x] has exactly MaxPacketSize bytes in its data block. + The size of the block allocated will be + sizeof(SPXRec) + + NumECBs * (sizeof(TipxECB) + sizeof(TspxHeader) + MaxPacketSize) + which will be a maximum of 10,364 bytes.} + + {get simple checks out of the way} + SPXAllocEventRec := nil; + if (NumECBs < 2) or (NumECBs > SPXMaxPoolCount) or + (MaxPacketSize = 0) or (MaxPacketSize > SPXMaxDataSize) then + Exit; + {calculate the block size, and allocate it in one go} + PoolRecSize := sizeof(TipxECB) + sizeof(TspxHeader) + MaxPacketSize; + Size := sizeof(TspxEventRec) + (NumECBs * PoolRecSize); + SPXEvent := IPXAllocPacket(Size); + if (SPXEvent = nil) then Exit; + {clean it up} + FillChar(SPXEvent^, Size, 0); + {set the values for the SPXRec fields} + with SPXEvent^ do + begin + {$IFDEF DPMIorWnd} + if (SPXRecList = nil) then + if not SPXAllocateDPMIESR then + begin + IPXFreePacket(PPacket(SPXEvent)); + SPXAllocEventRec := nil; + exit; + end; + {$ENDIF} + Next := SPXRecList; + SPXRecList := SPXEvent; + PacketSize := MaxPacketSize; + PoolCount := NumECBs; + {set up the pool pointers (in pmode these'll be pmode pointers)} + P := Ptr(OS(SPXEvent).S, OS(SPXEvent).O + sizeof(TspxEventRec)); + Pool[1] := P; + for Count := 2 to NumECBs do + begin + inc(OS(P).O, PoolRecSize); + Pool[Count] := P; + end; + {now initialize the pool ECBs' fragment descriptors: each ECB + has two descriptors, the first to the relevant SPX header, the + second to the data buffer. Real-mode pointers of course.} + for Count := 1 to NumECBs do + with Pool[Count]^.PoolECB do + begin + FragmentCount := 2; + {$IFDEF DPMIorWnd} + ESRAddress := SPXCallBack; + {$ELSE} + ESRAddress := @SPXCallBack; + {$ENDIF} + R := GetRealModePoolECBPtr(SPXEvent, Count); + FD1.Data := Ptr(OS(R).S, OS(R).O + sizeof(TipxECB)); + FD1.Size := sizeof(TspxHeader); + FD2.Data := Ptr(OS(R).S, OS(R).O + sizeof(TipxECB)+sizeof(TspxHeader)); + FD2.Size := PacketSize; + end; + end; + SPXAllocEventRec := SPXEvent; + end; +{--------} +procedure SPXFreeEventRec(SPXEvent : PspxEventRec); + var + Temp, Dad : PspxEventRec; + begin + if IsAnotherPacketType(SPXEvent) then Exit; + {unlink this SPXEvent from the linked list of Event records} + Temp := SPXRecList; + Dad := nil; + while (Temp <> nil) and (Temp <> SPXEvent) do + begin + Dad := Temp; + Temp := Temp^.Next; + end; + if (Temp <> nil) then + if (Dad = nil) then + begin + SPXRecList := Temp^.Next; + {$IFDEF DPMIorWnd} + if (SPXRecList = nil) then + SPXFreeDPMIESR; + {$ENDIF} + end + else + Dad^.Next := Temp^.Next; + + {free the SPXEvent as a packet} + IPXFreePacket(SPXEvent); + end; + + +{===SPX communications===} +function SPXSend(SPXEvent : PspxEventRec; + WaitForCompletion : boolean; + DataPacketSize : word; + DataPacket : PPacket) : byte; + var + FinalResult : byte; + begin + if IsAnotherPacketType(SPXEvent) then + begin + SPXSend := SPXErrBadEventRec; + Exit; + end; + if IsAnotherPacketType(DataPacket) then + begin + SPXSend := IPXErrBadPacket; + Exit; + end; + with SPXEvent^, ECB do + begin + if not AmConnected then + begin + SPXSend := SPXErrNoConnection; + Exit; + end; + {init the required fields of the send ECB} + {the high level SPX routines always use two buffer fragments. FD1 } + {points to the SPX header, and FD2 points to the user data.} + FragmentCount := 2; + with FD1 do + begin {point FD1 at the SPX header} + Data := GetRealModePtr(SPXEvent); + inc(OS(Data).O, sizeof(TipxECB)); + Size := SizeOf(TspxHeader); + end; + with FD2 do + begin {point FD2 at the user data} + Data := GetRealModePtr(DataPacket); + Size := DataPacketSize; + end; + Header.IPXHeader.PacketType := 5; {SPX packet} + {submit the send request to SPX} + SPXSendPrim(ConnID, GetRealModePtr(SPXEvent)); + if WaitForCompletion then + begin + repeat until SPXEventComplete(SPXEvent, FinalResult); + SPXSend := FinalResult; + end + else + SPXSend := 0; + end; + end; +{--------} +function SPXPacketReceived(SPXEvent : PspxEventRec; + var Index : byte; + var DataType : byte; + var CompletionCode : byte; + var DataPtr : pointer) : boolean; + var + RemoteHasGone : boolean; + begin + if IsAnotherPacketType(SPXEvent) then + begin + {if it's not a valid record, fake a received packet} + Index := 0; + DataType := 0; + CompletionCode := SPXErrBadEventRec; + DataPtr := nil; + SPXPacketReceived := true; + end + else + begin + IPXRelinquish; + + with SPXEvent^ do + if (QueueCount = 0) then + SPXPacketReceived := false + else + begin + RemoteHasGone := false; + SPXPacketReceived := true; + Index := Queue[1]; + with Pool[Queue[1]]^ do + begin + DataPtr := @PoolData; + DataType := PoolHeader.DataType; + {Check for the remote terminating the connection} + if (DataType = SPXEndOfConn) then + begin + RemoteHasGone := true; + CompletionCode := SPXErrRemoteHasGone; + end + else + begin + CompletionCode := PoolECB.CompletionCode; + {Check for the SPX watchdog noticing the connection + has been broken and informing us} + if (CompletionCode = SPXErrFailedConn) then + RemoteHasGone := true; + end; + end; + if RemoteHasGone then + SPXClearOnDisconnect(SPXEvent) + else + begin + DisableInterrupts; + dec(QueueCount); + if (QueueCount > 0) then + Move(Queue[2], Queue[1], QueueCount); + EnableInterrupts; + end; + end; + end; + end; +{--------} +procedure SPXReactivateECB(SPXEvent : PspxEventRec; + Index : byte); + begin + if not IsAnotherPacketType(SPXEvent) then + with SPXEvent^ do + if AmConnected and + (1 <= Index) and (Index <= PoolCount) and + (Pool[Index]^.PoolECB.InUse = 0) then + SPXListenPrim(GetRealModePoolECBPtr(SPXEvent, Index)); + end; + +function SPXECBsListening(SPXEvent : PspxEventRec) : byte; + var + Num : byte; + Index : word; + begin + Num := 0; + if not IsAnotherPacketType(SPXEvent) then + with SPXEvent^ do + for Index := 1 to PoolCount do + if (Pool[Index]^.PoolECB.InUse <> 0) then + inc(Num); + SPXECBsListening := Num; + end; + + +{===Opening an SPX Connection===} +function SPXEstablishConn(SPXEvent : PspxEventRec; + Receiver : IPXAddress; + LocalSocket : word; + RemoteSocket : word; + WaitForCompletion : boolean) : byte; + var + PoolIndex : word; + FinalResult : byte; + PrimResult : byte; + begin + PrimResult := 0; + if IsAnotherPacketType(SPXEvent) then + PrimResult := SPXErrBadEventRec + else if (LocalSocket = RemoteSocket) then + PrimResult := SPXErrSameSockets + else + begin + PrimResult := IPXOpenSocket(LocalSocket, false); + if (PrimResult = IPXErrSocketAlreadyOpen) then + PrimResult := 0; + end; + {if we have an error so far, exit} + if (PrimResult <> 0) then + begin + SPXEstablishConn := PrimResult; + Exit; + end; + {do the work} + with SPXEvent^ do + begin + {zeroize the connection ECB and SPX header, etc} + FillChar(ECB, sizeof(TipxECB), 0); + FillChar(Header, sizeof(TspxHeader), 0); + ConnID := 0; + QueueCount := 0; + {init the connection Event Control Block} + with ECB do + begin + SocketNumber := Swap(LocalSocket); + {we only use one buffer fragment to initiate a connection, + it should point to the the SPX header} + FragmentCount := 1; + with FD1 do + begin + Data := GetRealModePtr(SPXEvent); + inc(OS(Data).O, sizeof(TipxECB)); + Size := sizeof(TspxHeader); + end; + end; + {init the connection SPX header} + Receiver.Socket := Swap(RemoteSocket); + Header.IPXHeader.PacketType := 5; + Header.IPXHeader.Destination := Receiver; + + {post all the pooled listen ECBs - we've got to receive the + connection established message, etc} + for PoolIndex := 1 to PoolCount do + begin + with Pool[PoolIndex]^.PoolECB do + SocketNumber := Swap(LocalSocket); + SPXListenPrim(GetRealModePoolECBPtr(SPXEvent, PoolIndex)); + end; + + {call the low level establish connection routine} + PrimResult := SPXEstablishConnPrim(SPXRetryCount, + SPXWatchDog, + GetRealModePtr(SPXEvent), + ConnID); + SPXEstablishConn := PrimResult; + if (PrimResult = 0) then + begin + AmConnected := true; + if WaitForCompletion then + begin + repeat until SPXEventComplete(SPXEvent, FinalResult); + SPXEstablishConn := FinalResult; + end; + end; + end; + end; +{--------} +function SPXListenForConn(SPXEvent : PspxEventRec; + LocalSocket : word; + WaitForCompletion : boolean) : byte; + var + PoolIndex : word; + FinalResult : byte; + PrimResult : byte; + begin + PrimResult := 0; + if IsAnotherPacketType(SPXEvent) then + PrimResult := SPXErrBadEventRec + else + begin + PrimResult := IPXOpenSocket(LocalSocket, false); + if (PrimResult = IPXErrSocketAlreadyOpen) then + PrimResult := 0; + end; + {if we have an error so far, exit} + if (PrimResult <> 0) then + begin + SPXListenForConn := PrimResult; + Exit; + end; + {do the work} + with SPXEvent^ do + begin + {zeroize the connection ECB and SPX header, etc} + FillChar(ECB, sizeof(TipxECB), 0); + FillChar(Header, sizeof(TspxHeader), 0); + ConnID := 0; + QueueCount := 0; + {init the connection Event Control Block} + with ECB do + begin + SocketNumber := Swap(LocalSocket); + {we only use one buffer fragment to listen for a connection, + it should point to the the SPX header} + FragmentCount := 1; + with FD1 do + begin + Data := GetRealModePtr(SPXEvent); + inc(OS(Data).O, sizeof(TipxECB)); + Size := sizeof(TspxHeader); + end; + end; + {post all the pooled listen ECBs - we've got to receive the + Establish connection message, etc} + for PoolIndex := 1 to PoolCount do + begin + with Pool[PoolIndex]^.PoolECB do + SocketNumber := Swap(LocalSocket); + SPXListenPrim(GetRealModePoolECBPtr(SPXEvent, PoolIndex)); + end; + {call the low level establish connection routine} + SPXListenForConnPrim(SPXRetryCount, + SPXWatchDog, + GetRealModePtr(SPXEvent)); + if WaitForCompletion then + begin + repeat until SPXEventComplete(SPXEvent, FinalResult); + SPXListenForConn := FinalResult; + end + else + SPXListenForConn := 0; + end; + end; + + +{===Cancelling SPX Connections===} +procedure SPXTerminateConn(SPXEvent : PspxEventRec); + begin + if IsAnotherPacketType(SPXEvent) then Exit; + with SPXEvent^ do + begin + if not AmConnected then Exit; + SPXTerminateConnPrim(ConnID, GetRealModePtr(SPXEvent)); + while (ECB.InUse <> 0) do + IPXRelinquish; + end; + SPXClearOnDisconnect(SPXEvent); + end; +{--------} +procedure SPXCancelListenForConn(SPXEvent : PspxEventRec); + var + CancelResult : byte; + begin + if IsAnotherPacketType(SPXEvent) then Exit; + {An SPX Listen For Connection is cancelled with an IPX Cancel Event} + if (SPXEvent^.ECB.InUse <> 0) then + CancelResult := IPXCallWithECB(6, GetRealModePtr(SPXEvent)); + SPXClearOnDisconnect(SPXEvent); + end; +{--------} +procedure SPXAbortConn(SPXEvent : PspxEventRec); + begin + if IsAnotherPacketType(SPXEvent) then Exit; + with SPXEvent^ do + begin + if not AmConnected then Exit; + SPXAbortConnPrim(ConnID); + end; + SPXClearOnDisconnect(SPXEvent); + end; + +begin + {Automatically initialize IPX} + InitializeIPX; + {Set the 'do nothing' ESR addresses} + @IPXDoNothingESR := nil; + @AESDoNothingESR := nil; +end. + diff --git a/src/wc_sdk/nwmsg.pas b/src/wc_sdk/nwmsg.pas new file mode 100644 index 0000000..406c817 --- /dev/null +++ b/src/wc_sdk/nwmsg.pas @@ -0,0 +1,328 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$B+,F-,I-,R-,S-,V-} + {$IFDEF CanAllowOverlays} + {$F+,O+,A-} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-,P-} + {$ENDIF} + {all other compiler options are 'don't care'} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit NWMsg; + {-Unit to provide NetWare messaging functionality.} + +interface + +uses + NWBase, + NWConn; + +type + {Different broadcast message modes} + TnwBroadcastMode = (bmDisplayBoth, {display both server and user messages} + bmDisplayServer, {display only server messages} + bmStoreServer, {store only server messages} + bmStoreBoth); {store both server and user messages} + +{---Broadcast mode routines---} +function nwGetBroadcastMode(Server : TnwServer; + var Mode : TnwBroadcastMode) : TnwErrorCode; + {-Get the broadcast mode.} + +function nwSetBroadcastMode(Server : TnwServer; + Mode : TnwBroadcastMode) : TnwErrorCode; + {-Set the broadcast mode.} + +{---Message routines---} +function nwSendMessageToConsole(Server : TnwServer; + Message : string) : TnwErrorCode; + {-Send a message to the console.} + +function nwSendBroadcastMessage(Server : TnwServer; + Message : string; + var ToList : TnwConnList) : TnwErrorCode; + {-Broadcast a message to a group of connections. + Note: For NetWare 3.20 and above, the maximum number of connections + that can be sent to at once is 62 and the message length is 254 + characters; for earlier servers the corresponding values are 256 + connections and 58 characters.} + +function nwGetBroadcastMessage(Server : TnwServer; + var Message : string) : TnwErrorCode; + {-Get a broadcast message.} + +implementation + +function nwSendMessageToConsole(Server : TnwServer; + Message : string) : TnwErrorCode; + var + Request : record + Len : word; + Func : byte; + Msg : string[58]; + end; + Dummy : word; + begin + {API: Broadcast To Console} + with Request do + begin + Msg := Message; + Len := Length(Msg) + 2; + Func := $09; + end; + nwSendMessageToConsole := nwServerCall(Server, $15, + Request.Len+2, Request, + 0, Dummy); + end; + +function NETXGetBroadcastMode(Server : TnwServer; + var Mode : TnwBroadcastMode) : TnwErrorCode; + begin + {API: Get Broadcast Mode} + nwNETXPushServer(Server); + asm + mov ax, $DE00 + mov dl, $04 + int $21 + les di, Mode + mov es:[di], al + end; + nwNETXPopServer; + NETXGetBroadcastMode := 0; + end; + +function VLMGetBroadcastMode(Server : TnwServer; + var Mode : TnwBroadcastMode) : TnwErrorCode; + var + vlmResult : word; + Regs : TnwRegisters; + begin + {Note: the Novell Client API docs are ambiguous about whether a + workstation can have a different mode per server.} + {API: _NWP Message Handler} + nwInitRegs(Regs); + Regs.BX := $02; + Regs.DX := 4; + Regs.CX := Server; + vlmResult := vlmCall(vlmNWP, $0A, Regs); + if (vlmResult = 0) then + Mode := TnwBroadcastMode(Regs.DL); + VLMGetBroadcastMode := vlmResult; + end; + +function nwGetBroadcastMode(Server : TnwServer; + var Mode : TnwBroadcastMode) : TnwErrorCode; + begin + case nwShellType of + nsNETX : nwGetBroadcastMode := NETXGetBroadcastMode(Server, Mode); + nsVLM : nwGetBroadcastMode := VLMGetBroadcastMode(Server, Mode); + else + begin + nwGetBroadcastMode := nwErrShell; + end; + end;{case} + end; + +function NETXSetBroadcastMode(Server : TnwServer; + Mode : TnwBroadcastMode) : TnwErrorCode; + begin + {API: Set Broadcast Mode} + nwNETXPushServer(Server); + asm + mov ax, $DE00 + mov dl, Mode + int $21 + end; + nwNETXPopServer; + NETXSetBroadcastMode := 0; + end; + +function VLMSetBroadcastMode(Server : TnwServer; + Mode : TnwBroadcastMode) : TnwErrorCode; + var + Regs : TnwRegisters; + begin + {Note: the Novell Client API docs are ambiguous about whether a + workstation can have a different mode per server.} + {API: _NWP Message Handler} + nwInitRegs(Regs); + Regs.BX := $02; + Regs.DX := ord(Mode); + Regs.CX := Server; + VLMSetBroadcastMode := vlmCall(vlmNWP, $0A, Regs); + end; + +function nwSetBroadcastMode(Server : TnwServer; + Mode : TnwBroadcastMode) : TnwErrorCode; + begin + case nwShellType of + nsNETX : nwSetBroadcastMode := NETXSetBroadcastMode(Server, Mode); + nsVLM : nwSetBroadcastMode := VLMSetBroadcastMode(Server, Mode); + else + nwSetBroadcastMode := nwErrShell; + end;{case} + end; + +function nwGetBroadcastMessage(Server : TnwServer; + var Message : string) : TnwErrorCode; + var + Request : record + Len : word; + Func : byte; + end; + begin + {Note: the NWCALLS DLL uses server version 3.20 as the break point + between using function $01 or function $0B.} + {API: Get Broadcast Message} + with Request do + begin + Len := 1; + if (nwServerVersion(Server) >= $0320) then + Func := $0B + else Func := $01; + end; + nwGetBroadcastMessage := nwServerCall(Server, $15, + sizeof(Request), Request, + sizeof(Message), Message); + end; + +function Send1000UserMsg(Server : TnwServer; + Message : string; + var ToList : TnwConnList) : TnwErrorCode; + type + PRequest = ^TRequest; + TRequest = record {variably sized} + Len : word; + Func : byte; + Count: word; + Rest : array [0..199] of nwLong; + end; + var + Status : word; + ReqLen : word; + Request : PRequest; + i : word; + Reply : array [0..255] of byte; + begin + {API: Send Broadcast Message} + {Calc the size of the request packet: sizeof(Len+Func+Count) + + 4 bytes for each connection number + the message length + 1.} + ReqLen := 5 + (ToList.Count * 4) + 1 + length(Message); + if not nwGetMem(Request, ReqLen) then + Status := nwErrMemory + else + begin + with Request^ do + begin + Len := ReqLen - 2; + Func := $0A; + Count := ToList.Count; + for i := 0 to pred(Count) do + Rest[i] := ToList.List[i]; + Move(Message, Rest[Count], succ(length(Message))); + end; + Status := nwServerCall(Server, $15, ReqLen, Request^, + sizeof(Reply), Reply); + FreeMem(Request, ReqLen); + end; + Send1000UserMsg := Status; + end; + +function SendMsgOldStyle(Server : TnwServer; + Message : string; + var ToList : TnwConnList) : TnwErrorCode; + type + PRequest = ^TRequest; + TRequest = record {variably sized} + Len : word; + Func : byte; + Count: byte; + Rest : array [0..999] of byte; + end; + var + Status : word; + ReqLen : word; + Request : PRequest; + i : word; + Reply : array [0..255] of byte; + begin + {API: Send Broadcast Message (old)} + {Calc the size of the request packet: sizeof(Len+Func+Count) + + 1 byte for each connection number + the message length + 1.} + ReqLen := 5 + (ToList.Count) + 1 + length(Message); + if not nwGetMem(Request, ReqLen) then + Status := nwErrMemory + else + begin + with Request^ do + begin + Len := ReqLen - 2; + Func := $00; + Count := ToList.Count; + for i := 0 to pred(Count) do + Rest[i] := ToList.List[i]; + Move(Message, Rest[Count], nwMinI(59, succ(length(Message)))); + end; + Status := nwServerCall(Server, $15, ReqLen, Request^, + sizeof(Reply), Reply); + FreeMem(Request, ReqLen); + end; + SendMsgOldStyle := Status; + end; + +function nwSendBroadcastMessage(Server : TnwServer; + Message : string; + var ToList : TnwConnList) : TnwErrorCode; + begin + {Note: the NWCALLS DLL uses server version 3.20 as the break point + between using old style and new style calls.} + if (ToList.Count = 0) or (Message = '') then + begin + nwSendBroadcastMessage := 0; {success!} + Exit; + end; + if (nwServerVersion(Server) >= $0320) then + if (ToList.Count > 62) then {max num for 3.20+} + nwSendBroadcastMessage := nwErrTooManyConns + else + nwSendBroadcastMessage := Send1000UserMsg(Server, Message, ToList) + else {server is earlier than 3.20} + if (ToList.Count > 256) then {max num} + nwSendBroadcastMessage := nwErrTooManyConns + else + nwSendBroadcastMessage := SendMsgOldStyle(Server, Message, ToList); + end; + +end. diff --git a/src/wc_sdk/nwprint.pas b/src/wc_sdk/nwprint.pas new file mode 100644 index 0000000..ea496e6 --- /dev/null +++ b/src/wc_sdk/nwprint.pas @@ -0,0 +1,2082 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$B+,F-,I-,R-,S-,V-} + {$IFDEF CanAllowOverlays} + {$F+,O+,A-} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-,P-} + {$ENDIF} + {all other compiler options are 'don't care'} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit NWPrint; + {-Unit to provide NetWare printing functionality.} + +interface + +uses + {$IFDEF Windows} + {$IFDEF Ver80} + SysUtils, + DosSupp, + {$ELSE} + WinDOS, + {$ENDIF} + {$ELSE} + DOS, + {$ENDIF} + NWBase, + NWConn, + NWBind, + NWFile; + +const + {NWPRINT extra error codes} + nwpErrBadPrinter = $7F51; {Bad LPTx parameter, not enough printers.} + nwqErrNoSuchJob = $89D5; {No such job, it has been deleted or processed} + +const + {TnwCaptureFlags/TnwPrintJob: constants for PrintFlags field} + nwpfSuppressFF = $08; {do not issue form feed at end} + nwpfTabExpand = $40; {enable tab expansion} + nwpfPrintBanner = $80; {print banner page} + +const + {TnwPrintJob: constants for JobControlFlags field} + nwjcAutoStart = $08; {autostart even if server connection broken} + nwjcRestart = $10; {remains in queue after job cancelled} + nwjcEntryOpen = $20; {job file is being created} + nwjcUserHold = $40; {user has job on hold} + nwjcOperatorHold = $80; {operator has job on hold} + +const + {Constant to put in TnwPrintJob.TargetExecTime to print the job + as soon as possible} + nwPrintASAP : TnwDate = + (Year : $FFFF; Month : $FF; Day : $FF; + Hour : $FF; Minute : $FF; Second : $FF; + WeekDay: nwSun); + +type + {Enumeration function type for print queues.} + TnwEnumQueueFunc = function (Name : TnwObjectStr; ID : nwLong; + var ExtraData) : boolean; + {Enumeration function type for print jobs.} + TnwEnumPrintJobFunc = function (JobNumber : nwLong; + var ExtraData) : boolean; + + {Possible printers (LPT4-LPT9 only available with VLMs.} + TnwPrinter = (nwLPT1, nwLPT2, nwLPT3, + nwLPT4, nwLPT5, nwLPT6, + nwLPT7, nwLPT8, nwLPT9); + + {Banner strings: user name and job name} + TnwBannerName = string[12]; + TnwBannerJob = string[12]; + + {A form name string} + TnwFormName = string[12]; + + {Data used/returned by workstation capture commands} + TnwCaptureFlags = record + {read/write values, can be set with nwSetCaptureFlags} + PrintFlags : byte; {print flags} + TabSize : byte; {tab size (1..18)} + NumCopies : byte; {number of copies (0..255)} + FormType : byte; {form type (0..255)} + MaxLines : word; {maximum lines per page} + MaxCols : word; {maximum columns per line} + FlushTimeout : word; {ticks before automatic flush} + BannerJobName : TnwBannerJob; {print job name for banner page} + FlushOnClose : boolean; {true when autoflush enabled} + FormName : TnwFormName; {form name corresponding to FormType} + {read only values - returned by nwGetCaptureFlags} + Printer : TnwPrinter; {the local printer} + IsCaptured : boolean; {true if printer is captured} + IsCapturingData : boolean; {true if print data is being captured} + IsDoingTimeOut : boolean; {true if capture is timing out} + IsCapturedToFile : boolean; {true if captured to a file} + Server : TnwServer; {server processing the capture} + QueueID : nwLong; {print queue bindery ID if IsCapturedToFile is false} + end; + + {Print Queue Job data structure} + TnwPrintJob = record + VerifyFlag : word; {** verify flag} + Server : word; {** server handle} + QueueID : nwLong; {** print queue bindery ID} + ServerVersion : word; {** effective server version} + ClientStation : nwLong; {** client who started job: conn. number} + ClientTaskNum : nwLong; {** ...task number} + ClientID : nwLong; {** ...bindery object ID} + TargetServerID : nwLong; { print server ID, -1 = any} + TargetExecTime : TnwDate; { time to print job, $FF = ASAP} + JobEntryTime : TnwDate; {** time job entered the queue} + JobNumber : nwLong; {** job number} + JobType : word; { type of job (usually 0)} + JobPosition : word; {** position in queue, 1 = at top} + JobControlFlags: word; { job control flags} + JobFileName : string[13]; {** filename of queue job} + JobFileHandle : TnwFileHandle; {** NetWare handle of JobFileName} + ServerStation : nwLong; {** print server: conn.number} + ServerTaskNum : nwLong; {** ...task number} + ServerID : nwLong; {** ...bindery object ID} + JobDesc : string[49]; { description of job} + PrintFlags : byte; { print flags} + TabSize : byte; { default tab size} + FormName : TnwFormName; { name of form to print on} + NumCopies : byte; { number of copies} + MaxLines : word; { max lines per page} + MaxCols : word; { max columns per page} + BannerUserName : TnwBannerName; { user name for banner page} + BannerJobName : TnwBannerJob; { print job name for banner page} + JobFileSize : nwLong; { size of file JobFileName} + {** These fields are read only and are set by QMS, the others can + be altered by nwChangePrintJob + The TnwDate fields do not use or return the WeekDay field.} + end; + +{---Banner name routines---} +function nwGetBannerName(var Name : TnwBannerName) : TnwErrorCode; + {-Return the default banner user name.} + +function nwSetBannerName(Name : TnwBannerName) : TnwErrorCode; + {-Set the default banner user name.} + + +{---Capture routines---} +function nwCancelCapture(Printer : TnwPrinter) : TnwErrorCode; + {-Cancel capturing of Printer.} + +function nwEndCapture(Printer : TnwPrinter) : TnwErrorCode; + {-End capturing of Printer.} + +function nwFlushCapture(Printer : TnwPrinter) : TnwErrorCode; + {-Flush Printer's capture buffer. + Note: if caturing to a file, this will close the file and end + capturing under both VLMs and NETX.} + +function nwGetCaptureFlags(Printer : TnwPrinter; + var CapFlags : TnwCaptureFlags) : TnwErrorCode; + {-Get Printer's capture flags.} + +function nwGetNumPrinters : byte; + {-Get the number of printers the workstation can support.} + +function nwIsCaptured(Printer : TnwPrinter) : boolean; + {-Return true if Printer is being captured.} + +function nwSetCaptureFlags(Printer : TnwPrinter; + var CapFlags : TnwCaptureFlags) : TnwErrorCode; + {-Set Printer's capture flags.} + +function nwStartCaptureToFile(Printer: TnwPrinter; + FileName : string) : TnwErrorCode; + {-Start capturing Printer to a network file.} + +function nwStartCaptureToQueue(Printer : TnwPrinter; + Server : TnwServer; + QueueName : TnwObjectStr) : TnwErrorCode; + {-Start capturing Printer to a print queue.} + + +{---Queue routines---} +procedure nwEnumQueues(Server : TnwServer; + EnumFunc : TnwEnumQueueFunc; var ExtraData); + {-Enumerate all print queues on a server.} + +procedure nwqEnumPrintJobs(Server : TnwServer; QueueName : TnwObjectStr; + EnumFunc : TnwEnumPrintJobFunc; + var ExtraData); + {-Enumerate all print jobs on a print queue.} + +function nwqCreatePrintJobFile(Server : TnwServer; QueueName : TnwObjectStr; + var PrintJobData : TnwPrintJob; + var F : file) : TnwErrorCode; + {-Create a new print job on a queue and return a Pascal file variable + that you write to to add print data to the job.} + +function nwqClosePrintJobFile(var PrintJobData : TnwPrintJob; + var F : file) : TnwErrorCode; + {-Close a print job created by nwCreatePrintJobFile and release the + print job ready for printing. Closes the file variable as well.} + +function nwqAbortPrintJobFile(var PrintJobData : TnwPrintJob; + var F : file) : TnwErrorCode; + {-Close a print job created by nwCreatePrintJobFile and delete it. + Closes the file variable as well.} + +function nwqChangePrintJob(var PrintJobData : TnwPrintJob) : TnwErrorCode; + {-Change details of an existing print job.} + +function nwqChangePrintJobPos(var PrintJobData : TnwPrintJob; + NewPosition : word) : TnwErrorCode; + {-Change position of an existing print job. The user must be a + queue operator.} + +function nwqGetPrintJob(Server : TnwServer; QueueName : TnwObjectStr; + JobNumber : nwLong; + var PrintJobData : TnwPrintJob) : TnwErrorCode; + {-Given the number of a job and the queue it is on, return the + print job data structure.} + +function nwqRemovePrintJob(var PrintJobData : TnwPrintJob) : TnwErrorCode; + {-Delete an existing print job from the queue.} + +function nwqRefreshPrintJob(var PrintJobData : TnwPrintJob) : TnwErrorCode; + {-Refresh the data for an existing print job.} + +implementation + +type + OS = record O, S : word; end; {to split pointer into sel/seg & ofs} + LH = record L, H : word; end; {to split nwLong into hi/lo words} + +type + PString = ^string; + +type + TNewJobStruc = record {the raw new-style QueueJob structure} + rs0 : array [0..9] of byte; + cst, ctn, + coi, toi : nwLong; + tet, jet : array [0..5] of byte; + jnm : nwLong; + jtp : word; + jps, jcf : word; + jfn : string[13]; + jfh : array [0..3] of byte; + sst, stn, + soi : nwLong; + tjd : array [0..49] of char; + rs1, tbs, dm1, ncp, dm2, pfg : byte; + mxl, mxc : word; + fnm : array [0..15] of char; {Note: Bullets (Oct94) says [0..12]} + rs2 : array [0..5] of byte; {Note: Bullets (Oct94) says [0..8]} + bun, bjn : array [0..12] of char; + rs3 : array [1..94] of char; + end; + + TOldJobStruc = record {the raw old-style QueueJob structure} + cst, ctn : byte; + coi, toi : nwLong; + tet, jet : array [0..5] of byte; + jnm, jtp : word; + jps, jcf : byte; + jfn : array [0..13] of char; + jfh : array [0..5] of byte; + sst, stn : byte; + soi : nwLong; + tjd : array [0..49] of char; + rs1, tbs, dm1, ncp, dm2, pfg : byte; + mxl, mxc : word; + fnm : array [0..15] of char; {Note: Bullets (Oct94) says [0..12]} + rs2 : array [0..5] of byte; {Note: Bullets (Oct94) says [0..8]} + bun, bjn : array [0..12] of char; + rs3 : array [1..94] of char; + end; + +type + TCFBuffer = record {the raw capture flags structure} + st, pf, ts, pr, nc, ft, r1 : byte; + bt : array [0..13] of char; + ld : byte; + tc : word; + fc : byte; + ml, mc : word; + fn : array [0..12] of char; + cf, ff, tf : byte; + a1, a2 : nwLong; + sr, cp, pq, pj : byte; + oi : nwLong; + jn : word; + end; + +const + VerifyValue = $CAFE; + +{---Banner name routines---} + +function vlmGetBannerName(var Name : TnwBannerName) : TnwErrorCode; + {-Return banner name. VLM ONLY.} + var + Status: word; + Regs : TnwRegisters; + begin + {API: _PRINT Get Banner Name} + nwInitRegs(Regs); + with Regs do + begin + BX := 1; + {ES := OS(nwGlobalBufRealPtr).S;} {!!.51} + {DI := OS(nwGlobalBufRealPtr).O;} {!!.51} + ES := OS(nwGlobalBufVLM).S; {!!.51} + DI := OS(nwGlobalBufVLM).O; {!!.51} + end; + Status := vlmCall(vlmPrint, $0C, Regs); + if (Status <> 0) then + FillChar(Name, sizeof(TnwBannerName), 0) + else + begin + nwCvtAsciizToStr(nwGlobalBuf^, 12); + Name := PString(nwGlobalBuf)^; + end; + vlmGetBannerName := Status; + end; + +function NETXGetBannerName(var Name : TnwBannerName) : TnwErrorCode; + {-Return banner name. NETX ONLY.} + var + Status : word; + Regs : TnwRegisters; + begin + {API: Get Banner User Name} + FillChar(Name, sizeof(TnwBannerName), 0); + with Regs do + begin + nwInitRegs(Regs); + AX := $B808; + ES := OS(nwGlobalBufRealPtr).S; + BX := OS(nwGlobalBufRealPtr).O; + Status := nwIntr($21, Regs); + if (Status = 0) then + if (AL <> 0) then + Status := AL + NWerrBaseNETX; + end; + if (Status = 0) then + begin + nwCvtAsciizToStr(nwGlobalBuf^, 12); + Name := PString(nwGlobalBuf)^; + end; + NETXGetBannerName := Status; + end; + +function nwGetBannerName(var Name : TnwBannerName) : TnwErrorCode; + begin + case nwShellType of + nsNETX : nwGetBannerName := NETXGetBannerName(Name); + nsVLM : nwGetBannerName := vlmGetBannerName(Name); + else + nwGetBannerName := nwErrShell; + end;{case} + end; + +function vlmSetBannerName(Name : TnwBannerName) : TnwErrorCode; + {-Set the banner name. VLM ONLY.} + var + CallResult : word; + Regs : TnwRegisters; + begin + {API: _PRINT Set Banner Name} + nwInitRegs(Regs); + with Regs do + begin + FillChar(nwGlobalBuf^[0], sizeof(TnwBannerName), 0); + Move(Name[1], nwGlobalBuf^[0], length(Name)); + {DS := OS(nwGlobalBufRealPtr).S;} {!!.51} + {SI := OS(nwGlobalBufRealPtr).O;} {!!.51} + DS := OS(nwGlobalBufVLM).S; {!!.51} + SI := OS(nwGlobalBufVLM).O; {!!.51} + end; + vlmSetBannerName := vlmCall(vlmPrint, $0C, Regs); + end; + +function NETXSetBannerName(Name : TnwBannerName) : TnwErrorCode; + {-Set the banner name. NETX ONLY.} + var + Status : word; + Regs : TnwRegisters; + begin + {API: Set Banner User Name} + nwInitRegs(Regs); + with Regs do + begin + AX := $B809; + FillChar(nwGlobalBuf^[0], sizeof(TnwBannerName), 0); + Move(Name[1], nwGlobalBuf^[0], length(Name)); + ES := OS(nwGlobalBufRealPtr).S; + BX := OS(nwGlobalBufRealPtr).O; + Status := nwIntr($21, Regs); + if (Status = 0) then + if (AL <> 0) then + Status := AL + NWerrBaseNETX; + end; + NETXSetBannerName := Status; + end; + +function nwSetBannerName(Name : TnwBannerName) : TnwErrorCode; + begin + case nwShellType of + nsNETX : nwSetBannerName := NETXSetBannerName(Name); + nsVLM : nwSetBannerName := vlmSetBannerName(Name); + else + nwSetBannerName := nwErrShell; + end;{case} + end; + + +{---Capture routines---} +function nwGetNumPrinters : byte; + var + Regs : TnwRegisters; + begin + {Note: under NETX this always returns 3, under VLM the user is + allowed to set it anywhere from 0 to 9 in NET.CFG.} + if (nwShellType = nsVLM) then + begin + {API: _PRINT Get Num Of Printers} + nwInitRegs(Regs); + Regs.BX := 1; + if (vlmCall(vlmPrint, $07, Regs) = 0) then + nwGetNumPrinters := Regs.BL + else {the PRINT.VLM probably hasn't been loaded} + nwGetNumPrinters := 0 + end + else + nwGetNumPrinters := 3; + end; + +procedure CvtCapFlagsToPascal(var D; var CF : TnwCaptureFlags; + NewBufType : boolean); + {-Convert the buffer from the server to a Pascal capture flags record.} + var + CFBuf : TCFBuffer absolute D; + begin + FillChar(CF, sizeof(TnwCaptureFlags), 0); + with CF, CFBuf do + begin + PrintFlags := pf; + TabSize := ts; + NumCopies := nc; + FormType := ft; + {Note: bt is 14 bytes, BannerJobName is 13} + Move(bt, BannerJobName, sizeof(BannerJobName)); + nwCvtAsciizToStr(BannerJobName, pred(sizeof(BannerJobName))); + Printer := TnwPrinter(ld); + FlushTimeout := tc; + FlushOnClose := (fc = 0); + MaxLines := Swap(ml); + MaxCols := Swap(mc); + Move(fn, FormName, sizeof(fn)); + nwCvtAsciizToStr(FormName, pred(sizeof(FormName))); + IsCaptured := cf = $FF; + IsCapturingData := cp = $FF; + IsDoingTimeOut := tf = $FF; + IsCapturedToFile := ff = $FF; + if IsCaptured then + begin + if not NewBufType then + Server := sr; + if not IsCapturedToFile then + QueueID := oi; + end; + end; + end; + +function vlmGetCapFlags(Printer: TnwPrinter; + var CapFlags : TnwCaptureFlags) : TnwErrorCode; + {-Get the capture flags for Printer. VLM ONLY.} + var + Status : word; + Regs : TnwRegisters; + begin + {API: _PRINT Get Data, standard and extended control flags} + {Note: the job number field is returned properly by the PRINT VLM, + but since NETX doesn't, we ignore it.} + nwInitRegs(Regs); + with Regs do + begin + BX := 1; + CX := 63; + DX := ord(Printer); + {ES := OS(nwGlobalBufRealPtr).S;} {!!.51} + {DI := OS(nwGlobalBufRealPtr).O;} {!!.51} + ES := OS(nwGlobalBufVLM).S; {!!.51} + DI := OS(nwGlobalBufVLM).O; {!!.51} + end; + Status := vlmCall(vlmPrint, $04, Regs); + if (Status = 0) then + begin + CvtCapFlagsToPascal(nwGlobalBuf^[0], CapFlags, true); + if CapFlags.IsCaptured then + begin + {Note: the extended print control structure has changed from + that described in the Client API docs, but the server + number is still at offset 4, and that's all we want.} + nwInitRegs(Regs); + with Regs do + begin + BX := 3; + CX := 96; + DX := ord(Printer); + {ES := OS(nwGlobalBufRealPtr).S;} {!!.51} + {DI := OS(nwGlobalBufRealPtr).O;} {!!.51} + ES := OS(nwGlobalBufVLM).S; {!!.51} + DI := OS(nwGlobalBufVLM).O; {!!.51} + end; + Status := vlmCall(vlmPrint, $04, Regs); + if (Status = 0) then + Move(nwGlobalBuf^[4], CapFlags.Server, 2); + end; + end; + if (Status <> 0) then + FillChar(CapFlags, sizeof(CapFlags), 0); + vlmGetCapFlags := Status; + end; + +function NETXGetCapFlags(Printer: TnwPrinter; + var CapFlags : TnwCaptureFlags) : TnwErrorCode; + {-Get the capture flags for Printer. NETX ONLY.} + var + Status : word; + Regs : TnwRegisters; + begin + {API: Get Capture Flags} + {Note: as far as 4 byte job numbers are concerned, this API call is + broken. Under NETX 3.22 and 3.32 the JobNumber field is the + low word of the 4 byte job number, under NETX 3.26 it's the + high word. The GetJobNumber API call (AX=$B80B, DH=printer, + int $21) is also broken: it's not supported by NETX 3.22, for + NETX 3.26 it gives the high word in AX, the low word in DX, + for NETX 3.32 it gives the low word in both AX and DX. Thus + the job number is not returned by this routine.} + nwInitRegs(Regs); + with Regs do + begin + AX := $B802; + CX := 63; + ES := OS(nwGlobalBufRealPtr).S; + BX := OS(nwGlobalBufRealPtr).O; + DH := ord(Printer); + Status := nwIntr($21, Regs); + if (Status = 0) then + if (AL <> 0) then + Status := AL + NWerrBaseNETX; + end; + if (Status = 0) then + CvtCapFlagsToPascal(nwGlobalBuf^[0], CapFlags, false) + else + FillChar(CapFlags, sizeof(CapFlags), 0); + NETXGetCapFlags := Status; + end; + +function nwGetCaptureFlags(Printer: TnwPrinter; + var CapFlags : TnwCaptureFlags) : TnwErrorCode; + begin + if (ord(Printer) >= nwGetNumPrinters) then + begin + nwGetCaptureFlags := nwpErrBadPrinter; + Exit; + end; + case nwShellType of + nsNETX : nwGetCaptureFlags := NETXGetCapFlags(Printer, CapFlags); + nsVLM : nwGetCaptureFlags := vlmGetCapFlags(Printer, CapFlags); + else + nwGetCaptureFlags := nwErrShell; + end;{case} + end; + +procedure CvtPascalToCapFlags(var D; var CF : TnwCaptureFlags); + {-Convert the Pascal capture flags record to a buffer for the server} + var + CFBuf : TCFBuffer absolute D; + begin + FillChar(CFBuf, 42, 0); {there are 42 bytes of read/write fields} + with CF, CFBuf do + begin + pf := PrintFlags; + ts := TabSize; + nc := NumCopies; + ft := FormType; + {Note: BannerJobName is 13 bytes, bt is 14} + Move(BannerJobName, bt, sizeof(BannerJobName)); + nwCvtStrToAsciiz(bt, pred(sizeof(bt))); + ld := ord(Printer); + tc := FlushTimeout; + if FlushOnClose then + fc := 0 + else fc := $FF; + ml := Swap(MaxLines); + mc := Swap(MaxCols); + Move(FormName, fn, sizeof(fn)); + nwCvtStrToAsciiz(fn, pred(sizeof(fn))); + end; + end; + +function vlmSetCapFlags(Printer: TnwPrinter; + var CapFlags : TnwCaptureFlags) : TnwErrorCode; + {-Set the capture flags for Printer. VLM ONLY.} + var + Regs : TnwRegisters; + begin + {API: _PRINT Set Data} + CvtPascalToCapFlags(nwGlobalBuf^, CapFlags); + nwInitRegs(Regs); + with Regs do + begin + CX := 42; + DX := ord(Printer); + {DS := OS(nwGlobalBufRealPtr).S;} {!!.51} + {SI := OS(nwGlobalBufRealPtr).O;} {!!.51} + DS := OS(nwGlobalBufVLM).S; {!!.51} + SI := OS(nwGlobalBufVLM).O; {!!.51} + end; + vlmSetCapFlags := vlmCall(vlmPrint, $04, Regs); + end; + +function NETXSetCapFlags(Printer: TnwPrinter; Default : boolean; + var CapFlags : TnwCaptureFlags) : TnwErrorCode; + {-Set the capture flags for Printer. NETX ONLY.} + var + Status : word; + Regs : TnwRegisters; + begin + {API: Set (Default) Capture Flags} + CvtPascalToCapFlags(nwGlobalBuf^, CapFlags); + nwInitRegs(Regs); + with Regs do + begin + if Default then + AX := $B801 + else + begin + AX := $B803; + DH := ord(Printer); + end; + CX := 42; + ES := OS(nwGlobalBufRealPtr).S; + BX := OS(nwGlobalBufRealPtr).O; + Status := nwIntr($21, Regs); + if (Status = 0) then + if (AL <> 0) then + Status := AL + NWerrBaseNETX; + end; + NETXSetCapFlags := Status; + end; + +function nwSetCaptureFlags(Printer: TnwPrinter; + var CapFlags : TnwCaptureFlags) : TnwErrorCode; + begin + if (ord(Printer) >= nwGetNumPrinters) then + begin + nwSetCaptureFlags := nwpErrBadPrinter; + Exit; + end; + if (CapFlags.NumCopies = 0) then {NetWare takes 0 as being 256!} + CapFlags.NumCopies := 1; + case nwShellType of + nsNETX : nwSetCaptureFlags := NETXSetCapFlags(Printer, false, CapFlags); + nsVLM : nwSetCaptureFlags := vlmSetCapFlags(Printer, CapFlags); + else + nwSetCaptureFlags := nwErrShell; + end;{case} + end; + +function vlmIsCaptured(Printer : TnwPrinter) : boolean; + {-Return true if Printer is captured. VLM ONLY.} + var + Status : word; + Regs : TnwRegisters; + begin + {API: _PRINT Redirection} + vlmIsCaptured := false; + nwInitRegs(Regs); + with Regs do + begin + BX := 1; + DX := ord(Printer); + {ES := OS(nwGlobalBufRealPtr).S;} {!!.51} + {DI := OS(nwGlobalBufRealPtr).O;} {!!.51} + ES := OS(nwGlobalBufVLM).S; {!!.51} + DI := OS(nwGlobalBufVLM).O; {!!.51} + end; + Status := vlmCall(vlmPrint, $08, Regs); + if (Status = 0) then + vlmIsCaptured := true; + end; + +function NETXIsCaptured(Printer : TnwPrinter) : boolean; + {-Return true if Printer is captured. NETX ONLY.} + var + Status : word; + CF : TnwCaptureFlags; + begin + {Note: The Get LPT Capture Status API (INT $21, AX=$F003) + returns true for all printers under NETX 3.32 whether + they are captured or not. This may also be true for + earlier versions of NETX. However, the capture flags + for the required printer has the correct setting.} + NETXIsCaptured := false; + Status := NETXGetCapFlags(Printer, CF); + if (Status = 0) then + NETXIsCaptured := CF.IsCaptured; + end; + +function nwIsCaptured(Printer : TnwPrinter) : boolean; + begin + if (ord(Printer) >= nwGetNumPrinters) then + begin + nwIsCaptured := false; + Exit; + end; + case nwShellType of + nsNETX : nwIsCaptured := NETXIsCaptured(Printer); + nsVLM : nwIsCaptured := vlmIsCaptured(Printer); + else + nwIsCaptured := false; + end;{case} + end; + +function vlmCancelCapture(Printer: TnwPrinter) : TnwErrorCode; + {-Cancel capture of Printer. VLM ONLY.} + var + Regs : TnwRegisters; + begin + {API: _PRINT Redirection} + nwInitRegs(Regs); + Regs.BX := 2; + Regs.DX := ord(Printer); + vlmCancelCapture := vlmCall(vlmPrint, $08, Regs); + end; + +function NETXCancelCapture(Printer: TnwPrinter) : TnwErrorCode; + {-Cancel capture of Printer. NETX ONLY.} + var + Status : word; + Regs : TnwRegisters; + begin + {API: Cancel LPT Capture} + nwInitRegs(Regs); + with Regs do + begin + AX := $DF00; + DL := $06; + DH := ord(Printer); + Status := nwIntr($21, Regs); + if (Status = 0) then + if (AL <> 0) then + Status := AL + NWerrBaseNETX; + end; + NETXCancelCapture := Status; + end; + +function nwCancelCapture(Printer: TnwPrinter) : TnwErrorCode; + begin + if (ord(Printer) >= nwGetNumPrinters) then + begin + nwCancelCapture := nwpErrBadPrinter; + Exit; + end; + case nwShellType of + nsNETX : nwCancelCapture := NETXCancelCapture(Printer); + nsVLM : nwCancelCapture := vlmCancelCapture(Printer); + else + nwCancelCapture := nwErrShell; + end;{case} + end; + +function vlmFlushCapture(Printer: TnwPrinter) : TnwErrorCode; + {-Flush capture of Printer. VLM ONLY. + Note: if the printer is being captured to file, this call + closes the file, and cancels the capture.} + var + Status : word; + Regs : TnwRegisters; + begin + {API: _PRINT Flush & Close Job} + nwInitRegs(Regs); + Regs.DX := ord(Printer); + vlmFlushCapture := vlmCall(vlmPrint, $09, Regs); + end; + +function vlmEndCapture(Printer: TnwPrinter) : TnwErrorCode; + {-End capture of Printer. VLM ONLY.} + var + Status : word; + begin + {Note: There is no 'end capture' API call for VLM, so we do a + flush followed by a cancel. + vlmFlushCapture will leave the printer captured *unless* + the printer was captured to file. So we must check that + the printer is still captured before calling + vlmCancelCapture.} + Status := vlmFlushCapture(Printer); + if (Status = 0) and vlmIsCaptured(Printer) then + Status := vlmCancelCapture(Printer); + vlmEndCapture := Status; + end; + +function NETXEndCapture(Printer: TnwPrinter) : TnwErrorCode; + {-End capture of Printer. NETX ONLY.} + var + Status : word; + Regs : TnwRegisters; + begin + {API: End LPT Capture} + nwInitRegs(Regs); + with Regs do + begin + AX := $DF00; + DL := $05; + DH := ord(Printer); + Status := nwIntr($21, Regs); + if (Status = 0) then + if (AL <> 0) then + Status := AL + NWerrBaseNETX; + end; + NETXEndCapture := Status; + end; + +function NETXFlushCapture(Printer: TnwPrinter) : TnwErrorCode; + {-Flush capture of Printer. NETX ONLY.} + var + Status : word; + Regs : TnwRegisters; + CF : TnwCaptureFlags; + begin + {API: Flush LPT Capture} + {Note: Because a VLM flush call will end a capture if the + printer was captured to file and and NETX doesn't (it + leaves the printer captured to some 'default' queue), + we shall end the capture to file for NETX in order to + be consistent.} + Status := NETXGetCapFlags(Printer, CF); + if (Status = 0) then + begin + nwInitRegs(Regs); + with Regs do + begin + AX := $DF00; + DL := $07; + DH := ord(Printer); + Status := nwIntr($21, Regs); + if (Status = 0) then + if (AL <> 0) then + Status := AL + NWerrBaseNETX; + end; + if (Status = 0) and CF.IsCapturedToFile then + Status := NETXEndCapture(Printer); + end; + NETXFlushCapture := Status; + end; + +function nwFlushCapture(Printer: TnwPrinter) : TnwErrorCode; + begin + if (ord(Printer) >= nwGetNumPrinters) then + begin + nwFlushCapture := nwpErrBadPrinter; + Exit; + end; + case nwShellType of + nsNETX : nwFlushCapture := NETXFlushCapture(Printer); + nsVLM : nwFlushCapture := vlmFlushCapture(Printer); + else + nwFlushCapture := nwErrShell; + end;{case} + end; + +function nwEndCapture(Printer: TnwPrinter) : TnwErrorCode; + begin + if (ord(Printer) >= nwGetNumPrinters) then + begin + nwEndCapture := nwpErrBadPrinter; + Exit; + end; + case nwShellType of + nsNETX : nwEndCapture := NETXEndCapture(Printer); + nsVLM : nwEndCapture := vlmEndCapture(Printer); + else + nwEndCapture := nwErrShell; + end;{case} + end; + +function NETXStartCapture(Printer : TnwPrinter) : TnwErrorCode; + {-Start the capture for Printer. NETX ONLY.} + var + Status : word; + Regs : TnwRegisters; + begin + {API: Start LPT Capture} + nwInitRegs(Regs); + with Regs do + begin + AX := $DF00; + DL := $04; + DH := ord(Printer); + Status := nwIntr($21, Regs); + if (Status = 0) then + if (AL <> 0) then + Status := AL + NWerrBaseNETX; + end; + NETXStartCapture := Status; + end; + +function vlmStartCaptureToQueue(Printer: TnwPrinter; + Server : TnwServer; + QID : nwLong; + QueueName : TnwObjectStr) : TnwErrorCode; + {-Start the capture for Printer to a queue. VLM ONLY.} + var + Regs : TnwRegisters; + begin + {API: _PRINT Redirection} + nwUpperStr(QueueName); + nwInitRegs(Regs); + with Regs do + begin + AX := length(QueueName); + CX := Server; + DX := ord(Printer); + Move(QID, nwGlobalBuf^[0], sizeof(QID)); + Move(QueueName[1], nwGlobalBuf^[sizeof(QID)], length(QueueName)); + {ES := OS(nwGlobalBufRealPtr).S;} {!!.51} + {DI := OS(nwGlobalBufRealPtr).O;} {!!.51} + ES := OS(nwGlobalBufVLM).S; {!!.51} + DI := OS(nwGlobalBufVLM).O; {!!.51} + DS := ES; + SI := DI + sizeof(QID); + end; + vlmStartCaptureToQueue := vlmCall(vlmPrint, $08, Regs); + end; + +function NETXStartCaptureToQueue(Printer: TnwPrinter; + Server : TnwServer; + QID : nwLong) : TnwErrorCode; + {-Start the capture for Printer to a queue. NETX ONLY.} + var + Status : word; + Regs : TnwRegisters; + begin + {API: Set Capture Print Queue} + nwNETXPushServer(Server); + nwInitRegs(Regs); + with Regs do + begin + AX := $B806; + DH := ord(Printer); + DL := Server; + BX := LH(QID).L; + CX := LH(QID).H; + Status := nwIntr($21, Regs); + if (Status = 0) then + if (AL <> 0) then + Status := AL + NWerrBaseNETX; + end; + if (Status = 0) then + Status := NETXStartCapture(Printer); + nwNETXPopServer; + NETXStartCaptureToQueue := Status; + end; + +function nwStartCaptureToQueue(Printer: TnwPrinter; + Server : TnwServer; + QueueName : TnwObjectStr) : TnwErrorCode; + var + Status : word; + QID : nwLong; + begin + if (ord(Printer) >= nwGetNumPrinters) then + begin + nwStartCaptureToQueue := nwpErrBadPrinter; + Exit; + end; + Status := nwbGetObjectID(Server, NWboPrintQueue, QueueName, QID); + if (Status = 0) then + case nwShellType of + nsNETX : Status := NETXStartCaptureToQueue(Printer, Server, QID); + nsVLM : Status := vlmStartCaptureToQueue(Printer, Server, QID, QueueName); + else + nwStartCaptureToQueue := nwErrShell; + end;{case} + nwStartCaptureToQueue := Status; + end; + +function vlmStartCaptureToFile(Printer: TnwPrinter; + var FileName : string) : TnwErrorCode; + {-Start the capture for Printer to a file. VLM ONLY.} + var + Status : word; + Regs : TnwRegisters; + Server : TnwServer; + SName : TnwServerName; + VName : TnwVolumeName; + Path : string; + begin + {API: _PRINT Redirection} + Status := nwParseFileName(FileName, Server, SName, VName, Path); + if (Status = 0) and (Server = 0) then + Status := nwfErrNotOnServer; + if (Status = 0) then + begin + nwInitRegs(Regs); + with Regs do + begin + BX := 3; + CX := Server; + DX := ord(Printer); + Move(VName[1], nwGlobalBuf^[0], length(VName)); + Move(Path[1], nwGlobalBuf^[length(VName)], length(Path)); + nwGlobalBuf^[length(VName)+length(Path)] := 0; + {ES := OS(nwGlobalBufRealPtr).S;} {!!.51} + {DI := OS(nwGlobalBufRealPtr).O;} {!!.51} + ES := OS(nwGlobalBufVLM).S; {!!.51} + DI := OS(nwGlobalBufVLM).O; {!!.51} + end; + Status := vlmCall(vlmPrint, $08, Regs); + end; + vlmStartCaptureToFile := Status; + end; + +function NETXStartCaptureToFile(Printer: TnwPrinter; + var FileName : string) : TnwErrorCode; + {-Start the capture for Printer to a file. NETX ONLY.} + var + ReqLen : word; + Status : word; + Regs : TnwRegisters; + Server : TnwServer; + SName : TnwServerName; + VName : TnwVolumeName; + Path : string; + CF : TnwCaptureFlags; + begin + {API: Specify Capture File} + {Notes: this is somewhat fiddly as the NETX Specify Capture File + call only works on the default printer, not on specific + printers. Hence we set the default printer to the required + printer and start the capture.} + Status := nwParseFileName(FileName, Server, SName, VName, Path); + if (Status = 0) and (Server = 0) then + Status := nwfErrNotOnServer; + if (Status = 0) then + begin + Status := NETXGetCapFlags(Printer, CF); + if (Status = 0) then + begin + CF.Printer := Printer; + Status := NETXSetCapFlags(Printer, true, CF); + end; + if (Status = 0) then + begin + nwNETXPushServer(Server); + FillChar(nwGlobalBuf^, 262, 0); + ReqLen := 3 + length(VName) + length(Path); + nwGlobalBuf^[2] := Lo(ReqLen); + nwGlobalBuf^[3] := Hi(ReqLen); + nwGlobalBuf^[4] := $09; + nwGlobalBuf^[6] := length(VName) + length(Path); + Move(VName[1], nwGlobalBuf^[7], length(VName)); + Move(Path[1], nwGlobalBuf^[length(VName)+7], length(Path)); + nwInitRegs(Regs); + with Regs do + begin + AX := $E009; + ES := OS(nwGlobalBufRealPtr).S; + DI := OS(nwGlobalBufRealPtr).O; + DS := ES; + SI := DI + 2; + Status := nwIntr($21, Regs); + if (Status = 0) then + if (AL <> 0) then + Status := AL + NWerrBaseNETX; + end; + if (Status = 0) then + Status := NETXStartCapture(Printer); + nwNETXPopServer; + end; + end; + NETXStartCaptureToFile := Status; + end; + +function nwStartCaptureToFile(Printer: TnwPrinter; + FileName : string) : TnwErrorCode; + begin + if (ord(Printer) >= nwGetNumPrinters) then + begin + nwStartCaptureToFile := nwpErrBadPrinter; + Exit; + end; + case nwShellType of + nsNETX : nwStartCaptureToFile := + NETXStartCaptureToFile(Printer, FileName); + nsVLM : nwStartCaptureToFile := + vlmStartCaptureToFile(Printer, FileName); + else + nwStartCaptureToFile := nwErrShell; + end;{case} + end; + + +{---QUEUE ROUTINES---} + +procedure nwEnumQueues(Server : TnwServer; + EnumFunc : TnwEnumQueueFunc; var ExtraData); + var + Dyn : boolean; + Props : boolean; + Sec : byte; + StillEnumerating : boolean; + ObjType : word; + Status : word; + LastID : nwLong; + LastName : TnwObjectStr; + begin + StillEnumerating := true; + LastID := -1; + ObjType := nwboPrintQueue; + while StillEnumerating do + begin + LastName := '*'; + Status := nwbScanObject(Server, + ObjType, + LastName, LastID, + Dyn, Sec, Props); + if (Status = 0) then + StillEnumerating := EnumFunc(LastName, LastID, ExtraData) + else StillEnumerating := false; + end; + end; + +function CvtByteYear(yb : byte) : word; near; + begin + if (yb = $FF) then + CvtByteYear := $FFFF + else if (yb < 80) then + CvtByteYear := 2000 + yb + else + CvtByteYear := 1900 + yb; + end; + +function CvtWordYear(yw : word) : byte; near; + begin + if (yw = $FFFF) then + CvtWordYear := $FF + else if (2000 <= yw) and (yw <= 2079) then + CvtWordYear := yw - 2000 + else if (1980 <= yw) and (yw <= 1999) then + CvtWordYear := yw - 1900 + else + CvtWordYear := 80; + end; + +procedure CvtOldPJDToPascal(var D : TOldJobStruc; var PJD : TnwPrintJob); near; + begin + with PJD, D do + begin + ClientStation := cst; + ClientTaskNum := ctn; + ClientID := coi; + TargetServerID := toi; + TargetExecTime.Year := CvtByteYear(tet[0]); + Move(tet[1], TargetExecTime.Month, 5); + JobEntryTime.Year := CvtByteYear(jet[0]); + Move(jet[1], JobEntryTime.Month, 5); + JobNumber := jnm; + JobType := jtp; + JobPosition := jps; + JobControlFlags := jcf; + Move(jfn, JobFileName, sizeof(JobFileName)); + nwCvtAsciizToStr(JobFileName, pred(sizeof(JobFileName))); + Move(jfh, JobFileHandle, sizeof(JobFileHandle)); + ServerStation := sst; + ServerTaskNum := stn; + ServerID := soi; + Move(tjd, JobDesc, sizeof(JobDesc)); + nwCvtAsciizToStr(JobDesc, pred(sizeof(JobDesc))); + TabSize := tbs; + NumCopies := ncp; + PrintFlags := pfg; + MaxLines := Swap(mxl); + MaxCols := Swap(mxc); + Move(fnm, FormName, sizeof(FormName)); + nwCvtAsciizToStr(FormName, pred(sizeof(FormName))); + Move(bun, BannerUserName, sizeof(BannerUserName)); + nwCvtAsciizToStr(BannerUserName, pred(sizeof(BannerUserName))); + Move(bjn, BannerJobName, sizeof(BannerJobName)); + nwCvtAsciizToStr(BannerJobName, pred(sizeof(BannerJobName))); + end; + end; + +procedure CvtNewPJDToPascal(var D : TNewJobStruc; var PJD : TnwPrintJob); + begin + with PJD, D do + begin + ClientStation := cst; + ClientTaskNum := ctn; + ClientID := coi; + TargetServerID := toi; + TargetExecTime.Year := CvtByteYear(tet[0]); + Move(tet[1], TargetExecTime.Month, 5); + JobEntryTime.Year := CvtByteYear(jet[0]); + Move(jet[1], JobEntryTime.Month, 5); + JobNumber := jnm; + JobType := jtp; + JobPosition := jps; + JobControlFlags := jcf; + JobFileName := jfn; + {the 4-byte jfh goes into the last 4 bytes of JobFileHandle} + Move(jfh, JobFileHandle[1], sizeof(jfh)); + ServerStation := sst; + ServerTaskNum := stn; + ServerID := soi; + Move(tjd, JobDesc, sizeof(JobDesc)); + nwCvtAsciizToStr(JobDesc, pred(sizeof(JobDesc))); + TabSize := tbs; + NumCopies := ncp; + PrintFlags := pfg; + MaxLines := Swap(mxl); + MaxCols := Swap(mxc); + Move(fnm, FormName, sizeof(FormName)); + nwCvtAsciizToStr(FormName, pred(sizeof(FormName))); + Move(bun, BannerUserName, sizeof(BannerUserName)); + nwCvtAsciizToStr(BannerUserName, pred(sizeof(BannerUserName))); + Move(bjn, BannerJobName, sizeof(BannerJobName)); + nwCvtAsciizToStr(BannerJobName, pred(sizeof(BannerJobName))); + end; + end; + +procedure CvtPascalToOldPJD(var D : TOldJobStruc; var PJD : TnwPrintJob); + begin + {Note: only convert the fields that can be changed by the user, + plus the job number so that QMS can recognize it} + FillChar(D, sizeof(D), 0); + with PJD, D do + begin + toi := TargetServerID; + tet[0] := CvtWordYear(TargetExecTime.Year); + Move(TargetExecTime.Month, tet[1], 5); + jnm := JobNumber; + jtp := JobType; + jcf := JobControlFlags; + Move(JobDesc[1], tjd[0], length(JobDesc)); + tbs := TabSize; + ncp := NumCopies; + pfg := PrintFlags; + mxl := Swap(MaxLines); + mxc := Swap(MaxCols); + Move(FormName[1], fnm[0], length(FormName)); + Move(BannerUserName[1], bun[0], length(BannerUserName)); + Move(BannerJobName[1], bjn[0], length(BannerJobName)); + end; + end; + +procedure CvtPascalToNewPJD(var D : TNewJobStruc; var PJD : TnwPrintJob); + begin + {Note: only convert the fields that can be changed by the user, + plus the job number so that QMS can recognize it} + FillChar(D, sizeof(D), 0); + with PJD, D do + begin + toi := TargetServerID; + tet[0] := CvtWordYear(TargetExecTime.Year); + Move(TargetExecTime.Month, tet[1], 5); + jnm := JobNumber; + jtp := JobType; + jcf := JobControlFlags; + Move(JobDesc[1], tjd[0], length(JobDesc)); + tbs := TabSize; + ncp := NumCopies; + pfg := PrintFlags; + mxl := Swap(MaxLines); + mxc := Swap(MaxCols); + Move(FormName[1], fnm[0], length(FormName)); + Move(BannerUserName[1], bun[0], length(BannerUserName)); + Move(BannerJobName[1], bjn[0], length(BannerJobName)); + end; + end; + +function ReadPrintJobEntryOld(var PrintJobData : TnwPrintJob) : TnwErrorCode; + var + Status : word; + Request : record + Len : word; + Func : byte; + QID : nwLong; + JobN : word; + end; + Reply : TOldJobStruc; + FReply: record + QID : nwLong; + JobN: word; + FSiz: nwLong; + end; + begin + {API: Read Queue Job Entry (old) + Get Queue Job File Size (old)} + with Request do + begin + Len := sizeof(Request) - 2; + Func := $6C; + QID := PrintJobData.QueueID; + JobN := PrintJobData.JobNumber; + end; + Status := nwServerCall(PrintJobData.Server, $17, sizeof(Request), Request, + sizeof(Reply), Reply); + if (Status = 0) then + begin + CvtOldPJDToPascal(Reply, PrintJobData); + with Request do + begin + Len := sizeof(Request) - 2; + Func := $78; + QID := PrintJobData.QueueID; + JobN := PrintJobData.JobNumber; + end; + Status := nwServerCall(PrintJobData.Server, $17, sizeof(Request), Request, + sizeof(FReply), FReply); + if (Status = 0) then + PrintJobData.JobFileSize := nwSwapLong(FReply.FSiz); + end; + ReadPrintJobEntryOld := Status; + end; + +function ReadPrintJobEntryNew(var PrintJobData : TnwPrintJob) : TnwErrorCode; + var + Status : word; + Request : record + Len : word; + Func : byte; + QID : nwLong; + JobN : nwLong; + end; + Reply : TNewJobStruc; + FReply: record + QID : nwLong; + JobN: nwLong; + FSiz: nwLong; + end; + begin + {API: Read Queue Job Entry + Get Queue Job File Size} + with Request do + begin + Len := sizeof(Request) - 2; + Func := $7A; + QID := PrintJobData.QueueID; + JobN := PrintJobData.JobNumber; + end; + Status := nwServerCall(PrintJobData.Server, $17, sizeof(Request), Request, + sizeof(Reply), Reply); + if (Status = 0) then + begin + CvtNewPJDToPascal(Reply, PrintJobData); + with Request do + begin + Len := sizeof(Request) - 2; + Func := $87; + QID := PrintJobData.QueueID; + JobN := PrintJobData.JobNumber; + end; + Status := nwServerCall(PrintJobData.Server, $17, sizeof(Request), Request, + sizeof(FReply), FReply); + if (Status = 0) then + PrintJobData.JobFileSize := nwSwapLong(FReply.FSiz); + end; + ReadPrintJobEntryNew := Status; + end; + +function nwqRefreshPrintJob(var PrintJobData : TnwPrintJob) : TnwErrorCode; + begin + if (PrintJobData.VerifyFlag <> VerifyValue) then + nwqRefreshPrintJob := NWerrBadData + else + if (PrintJobData.ServerVersion < ServerVersion311) then + nwqRefreshPrintJob := ReadPrintJobEntryOld(PrintJobData) + else + nwqRefreshPrintJob := ReadPrintJobEntryNew(PrintJobData) + end; + +function ChangePrintJobEntryOld(var PrintJobData : TnwPrintJob) : TnwErrorCode; + var + Status : word; + Request : record + Len : word; + Func : byte; + QID : nwLong; + JobD : TOldJobStruc; + end; + Dummy : word; + begin + {API: Change Queue Job Entry (old)} + with Request do + begin + Len := sizeof(Request) - 2; + Func := $6D; + QID := PrintJobData.QueueID; + CvtPascalToOldPJD(JobD, PrintJobData); + end; + Status := nwServerCall(PrintJobData.Server, $17, sizeof(Request), Request, + 0, Dummy); + if (Status = 0) then + Status := ReadPrintJobEntryOld(PrintJobData); + ChangePrintJobEntryOld := Status; + end; + +function ChangePrintJobEntryNew(var PrintJobData : TnwPrintJob) : TnwErrorCode; + var + Status : word; + Request : record + Len : word; + Func : byte; + QID : nwLong; + JobD : TNewJobStruc; + end; + Dummy : word; + begin + {API: Change Queue Job Entry} + with Request do + begin + Len := sizeof(Request) - 2; + Func := $7B; + QID := PrintJobData.QueueID; + CvtPascalToNewPJD(JobD, PrintJobData); + end; + Status := nwServerCall(PrintJobData.Server, $17, sizeof(Request), Request, + 0, Dummy); + if (Status = 0) then + Status := ReadPrintJobEntryNew(PrintJobData); + ChangePrintJobEntryNew := Status; + end; + +function nwqChangePrintJob(var PrintJobData : TnwPrintJob) : TnwErrorCode; + begin + if (PrintJobData.VerifyFlag <> VerifyValue) then + nwqChangePrintJob := NWerrBadData + else + begin + if (PrintJobData.NumCopies = 0) then {NetWare takes 0 as being 256!} + PrintJobData.NumCopies := 1; + if (PrintJobData.ServerVersion < ServerVersion311) then + nwqChangePrintJob := ChangePrintJobEntryOld(PrintJobData) + else + nwqChangePrintJob := ChangePrintJobEntryNew(PrintJobData); + end; + end; + +function ChangePrintJobPosition(var PrintJobData : TnwPrintJob; + NewPosn : word) : TnwErrorCode; + var + Status : word; + Request : record + Len : word; + Func : byte; + QID : nwLong; + JobN : word; + Posn : byte; + end; + Dummy : word; + begin + {API: Change Queue Job Position} + with Request do + begin + Len := sizeof(Request) - 2; + Func := $6E; + QID := PrintJobData.QueueID; + JobN := PrintJobData.JobNumber; + Posn := NewPosn; + end; + Status := nwServerCall(PrintJobData.Server, $17, sizeof(Request), Request, + 0, Dummy); + if (Status = 0) then + Status := ReadPrintJobEntryOld(PrintJobData); + ChangePrintJobPosition := Status; + end; + +function ChangeJobPriority(var PrintJobData : TnwPrintJob; + NewPosn : word) : TnwErrorCode; + var + Status : word; + Request : record + Len : word; + Func : byte; + QID : nwLong; + JobN : nwLong; + Posn : nwLong; + end; + Dummy : word; + begin + {API: Change Job Priority} + with Request do + begin + Len := sizeof(Request) - 2; + Func := $82; + QID := PrintJobData.QueueID; + JobN := PrintJobData.JobNumber; + Posn := NewPosn; + end; + Status := nwServerCall(PrintJobData.Server, $17, sizeof(Request), Request, + 0, Dummy); + if (Status = 0) then + Status := ReadPrintJobEntryNew(PrintJobData); + ChangeJobPriority := Status; + end; + +function nwqChangePrintJobPos(var PrintJobData : TnwPrintJob; + NewPosition : word) : TnwErrorCode; + begin + if (PrintJobData.VerifyFlag <> VerifyValue) then + nwqChangePrintJobPos := NWerrBadData + else + if (PrintJobData.ServerVersion < ServerVersion311) then + nwqChangePrintJobPos := ChangePrintJobPosition(PrintJobData, NewPosition) + else + nwqChangePrintJobPos := ChangeJobPriority(PrintJobData, NewPosition) + end; + +function RemovePrintJobEntryOld(var PrintJobData : TnwPrintJob) : TnwErrorCode; + var + Request : record + Len : word; + Func : byte; + QID : nwLong; + JobN : word; + end; + Dummy : word; + begin + {API: Remove Job From Queue (old)} + with Request do + begin + Len := sizeof(Request) - 2; + Func := $6A; + QID := PrintJobData.QueueID; + JobN := PrintJobData.JobNumber; + end; + RemovePrintJobEntryOld := nwServerCall(PrintJobData.Server, $17, + sizeof(Request), Request, + 0, Dummy); + end; + +function RemovePrintJobEntryNew(var PrintJobData : TnwPrintJob) : TnwErrorCode; + var + Request : record + Len : word; + Func : byte; + QID : nwLong; + JobN : nwLong; + end; + Dummy : word; + begin + {API: Remove Job From Queue} + with Request do + begin + Len := sizeof(Request) - 2; + Func := $80; + QID := PrintJobData.QueueID; + JobN := PrintJobData.JobNumber; + end; + RemovePrintJobEntryNew := nwServerCall(PrintJobData.Server, $17, + sizeof(Request), Request, + 0, Dummy); + end; + +function nwqRemovePrintJob(var PrintJobData : TnwPrintJob) : TnwErrorCode; + begin + if (PrintJobData.VerifyFlag <> VerifyValue) then + nwqRemovePrintJob := NWerrBadData + else + if (PrintJobData.ServerVersion < ServerVersion311) then + nwqRemovePrintJob := RemovePrintJobEntryOld(PrintJobData) + else + nwqRemovePrintJob := RemovePrintJobEntryNew(PrintJobData) + end; + +function CreatePrintJobAndFileOld(QueueID : nwLong; + var PrintJobData : TnwPrintJob) : TnwErrorCode; + var + Status : word; + Request : record + Len : word; + Func : byte; + QID : nwLong; + JobD : TOldJobStruc; + end; + Reply : record + Len : word; + JobD : array [0..53] of byte; + end; + Regs : TnwRegisters; + begin + {API: Create Queue Job And File (old)} + with Request do + begin + Len := sizeof(Request) - 2; + Func := $68; + QID := QueueID; + CvtPascalToOldPJD(JobD, PrintJobData); + end; + {Note: under NETX we can use the NETQ device *only* if we make a + call through the proper NETX calling sequence; NETX does + not filter the NCP calls for this function and so does not + notice and provide the NETQ device.} + if (nwShellType = nsNETX) then + begin + nwNETXPushServer(PrintJobData.Server); + Reply.Len := sizeof(Reply.JobD); + Move(Request, nwGlobalBuf^[0], sizeof(Request)); + Move(Reply, nwGlobalBuf^[sizeof(Request)], sizeof(Reply.Len)); + nwInitRegs(Regs); + with Regs do + begin + AH := $E3; + DS := OS(nwGlobalBufRealPtr).S; + SI := OS(nwGlobalBufRealPtr).O; + ES := DS; + DI := SI + sizeof(Request); + Status := nwIntr($21, Regs); + if (Status = 0) then + if (AL <> 0) then + Status := NWerrBaseNETX + AL; + end; + nwNETXPopServer; + if (Status = 0) then + Move(nwGlobalBuf^[sizeof(Request)], Reply, sizeof(Reply)); + end + else {it's a VLM} + Status := nwServerCall(PrintJobData.Server, $17, + sizeof(Request), Request, + sizeof(Reply.JobD), Reply.JobD); + if (Status = 0) then + begin + Move(Reply.JobD, Request.JobD, sizeof(Reply.JobD)); + CvtOldPJDToPascal(Request.JobD, PrintJobData); + end; + CreatePrintJobAndFileOld := Status; + end; + +function CreatePrintJobAndFileNew(QueueID : nwLong; + var PrintJobData : TnwPrintJob) : TnwErrorCode; + var + Status : word; + Request : record + Len : word; + Func : byte; + QID : nwLong; + JobD : TNewJobStruc; + end; + Reply : record + Len : word; + JobD : array [0..77] of byte; + end; + Regs : TnwRegisters; + begin + {API: Create Queue Job And File} + with Request do + begin + Len := sizeof(Request) - 2; + Func := $79; + QID := QueueID; + CvtPascalToNewPJD(JobD, PrintJobData); + end; + {Note: under NETX we can use the NETQ device *only* if we make a + call through the proper NETX calling sequence; NETX does + not filter the NCP calls for this function and so does not + notice and provide the NETQ device.} + if (nwShellType = nsNETX) then + begin + nwNETXPushServer(PrintJobData.Server); + Reply.Len := sizeof(Reply.JobD); + Move(Request, nwGlobalBuf^[0], sizeof(Request)); + Move(Reply, nwGlobalBuf^[sizeof(Request)], sizeof(Reply.Len)); + nwInitRegs(Regs); + with Regs do + begin + AH := $E3; + DS := OS(nwGlobalBufRealPtr).S; + SI := OS(nwGlobalBufRealPtr).O; + ES := DS; + DI := SI + sizeof(Request); + Status := nwIntr($21, Regs); + if (Status = 0) then + if (AL <> 0) then + Status := NWerrBaseNETX + AL; + end; + nwNETXPopServer; + if (Status = 0) then + Move(nwGlobalBuf^[sizeof(Request)], Reply, sizeof(Reply)); + end + else {it's a VLM} + Status := nwServerCall(PrintJobData.Server, $17, + sizeof(Request), Request, + sizeof(Reply.JobD), Reply.JobD); + if (Status = 0) then + begin + Move(Reply.JobD, Request.JobD, sizeof(Reply.JobD)); + CvtNewPJDToPascal(Request.JobD, PrintJobData); + end; + CreatePrintJobAndFileNew := Status; + end; + +function vlmMapNetWareHandle(var F : file; + var PJD : TnwPrintJob) : TnwErrorCode; + const + VLMfilename : array [0..7] of char = 'VLM_NETQ'; + type + TnwCSFT = record + Handle : TnwFileHandle; + Res1 : word; + NameZ : array [0..13] of char; + Attr : byte; + Res2 : byte; + Len : nwLong; + CreateDate : word; + AccessDate : word; + UpdateDate : word; + UpdateTime : word; + end; + var + Status : word; + {$IFDEF Windows} + FR : TFileRec absolute F; + {$ELSE} + FR : FileRec absolute F; + {$ENDIF} + CSFT : ^TnwCSFT; + Regs : TnwRegisters; + begin + {API: _REDIR Build SFT} + FillChar(FR, sizeof(FR), 0); + FR.RecSize := 1; + CSFT := pointer(nwGlobalBuf); + FillChar(CSFT^, sizeof(CSFT^), 0); + with CSFT^ do + begin + Handle := PJD.JobFileHandle; + Handle[0] := Handle[1] + 1; + Attr := 2; + end; + nwInitRegs(Regs); + with Regs do + begin + CX := PJD.Server; + {ES := OS(nwGlobalBufRealPtr).S;} {!!.51} + {DI := OS(nwGlobalBufRealPtr).O;} {!!.51} + ES := OS(nwGlobalBufVLM).S; {!!.51} + DI := OS(nwGlobalBufVLM).O; {!!.51} + Status := vlmCall(vlmRedir, $04, Regs); + if (Status = 0) then + begin + FR.Mode := fmInOut; + FR.Handle := BX; + Move(VLMfilename, FR.Name, sizeof(VLMfilename)); {for fun} + end + else + FR.Mode := fmClosed; + end; + vlmMapNetWareHandle := Status; + end; + + +function nwqCreatePrintJobFile(Server : TnwServer; QueueName : TnwObjectStr; + var PrintJobData : TnwPrintJob; + var F : file) : TnwErrorCode; + const + UnknownStr = '(unknown)'; + var + Status : word; + QID : nwLong; + SaveFileMode : integer; + begin + if (nwShellType = nsNone) then + begin + nwqCreatePrintJobFile := nwErrShell; + Exit; + end; + {Notes: This routine is greatly complicated by the different + combinations that can occur. Essentially there are two + different types of servers: ones that support only 255 + workstations and the others that support more. Also there + are essentially three different types of shell: the old NETX + that support up to 255 connections, the newer NETX that + support over 255 connections, and the VLMs. If an old NETX + is spotted accessing a server that supports over 255 + connections, then this routine 'pretends' that the server + is version 2.20 (ie that it doesn't support over 255 conns). + Also under NETX, the NETQ device only becomes visible *if* you + use the proper NETX call, and does not if you use the NCP + call. The Novell manuals are decidedly ambiguous about this.} + Status := nwbGetObjectID(Server, NWboPrintQueue, QueueName, QID); + if (Status = 0) then + begin + FillChar(PrintJobData, sizeof(PrintJobData), 0); + PrintJobData.Server := Server; + with PrintJobData do + begin + VerifyFlag := VerifyValue; + QueueID := QID; + ServerVersion := nwServerVersion(Server); + if (ServerVersion >= ServerVersion311) and + (nwShellType = nsNETX) and (nwShellVersion < NETXVersion330) then + ServerVersion := $0214; + TargetServerID := -1; + FillChar(TargetExecTime, pred(sizeof(TargetExecTime)), $FF); + JobDesc := UnknownStr; + NumCopies := 1; + if (nwGetBannerName(BannerUserName) <> 0) then + BannerUserName := UnknownStr; + BannerJobName := UnknownStr; + end; + if (PrintJobData.ServerVersion < ServerVersion311) then + Status := CreatePrintJobAndFileOld(QID, PrintJobData) + else + Status := CreatePrintJobAndFileNew(QID, PrintJobData); + if (Status = 0) then + case nwShellType of + nsNETX : + begin + nwNETXPushServer(PrintJobData.Server); + Assign(F, 'NETQ'); + SaveFileMode := FileMode; + FileMode := $42; {deny-none, read/write} + Reset(F, 1); {MUST use DOS open call, not create} + FileMode := SaveFileMode; + Status := IOResult; + nwNETXPopServer; + end; + nsVLM : + Status := vlmMapNetWareHandle(F, PrintJobData); + end;{case} + end; + nwqCreatePrintJobFile := Status; + end; + +function CloseFileAndStartPrintJobOld(var PrintJobData : TnwPrintJob) : TnwErrorCode; + var + Request : record + Len : word; + Func : byte; + QID : nwLong; + JobN : word; + end; + Dummy : word; + begin + {API: Close File And Start Queue Job (old)} + with Request do + begin + Len := sizeof(Request) - 2; + Func := $69; + QID := PrintJobData.QueueID; + JobN := PrintJobData.JobNumber; + end; + CloseFileAndStartPrintJobOld := nwServerCall(PrintJobData.Server, $17, + sizeof(Request), Request, + 0, Dummy); + end; + +function CloseFileAndStartPrintJobNew(var PrintJobData : TnwPrintJob) : TnwErrorCode; + var + Request : record + Len : word; + Func : byte; + QID : nwLong; + JobN : nwLong; + end; + Dummy : word; + begin + {API: Close File And Start Queue Job} + with Request do + begin + Len := sizeof(Request) - 2; + Func := $7F; + QID := PrintJobData.QueueID; + JobN := PrintJobData.JobNumber; + end; + CloseFileAndStartPrintJobNew := nwServerCall(PrintJobData.Server, $17, + sizeof(Request), Request, + 0, Dummy); + end; + +function nwqClosePrintJobFile(var PrintJobData : TnwPrintJob; + var F : file) : TnwErrorCode; + begin + if (PrintJobData.VerifyFlag <> VerifyValue) then + nwqClosePrintJobFile := NWerrBadData + else + begin + Close(F); + if (IOresult <> 0) then + {nothing}; + if (PrintJobData.ServerVersion < ServerVersion311) then + nwqClosePrintJobFile := CloseFileAndStartPrintJobOld(PrintJobData) + else + nwqClosePrintJobFile := CloseFileAndStartPrintJobNew(PrintJobData); + end; + end; + +function nwqAbortPrintJobFile(var PrintJobData : TnwPrintJob; + var F : file) : TnwErrorCode; + begin + if (PrintJobData.VerifyFlag <> VerifyValue) then + nwqAbortPrintJobFile := NWerrBadData + else + begin + Close(F); + if (IOresult <> 0) then + {nothing}; + nwqAbortPrintJobFile := nwqRemovePrintJob(PrintJobData); + end; + end; + +function nwqGetPrintJob(Server : TnwServer; QueueName : TnwObjectStr; + JobNumber : nwLong; + var PrintJobData : TnwPrintJob) : TnwErrorCode; + var + Status : word; + QID : nwLong; + begin + if (nwShellType = nsNone) then + Status := nwErrShell + else + begin + Status := nwbGetObjectID(Server, NWboPrintQueue, QueueName, QID); + if (Status = 0) then + begin + FillChar(PrintJobData, sizeof(PrintJobData), 0); + PrintJobData.Server := Server; + PrintJobData.JobNumber := JobNumber; + with PrintJobData do + begin + VerifyFlag := VerifyValue; + QueueID := QID; + ServerVersion := nwServerVersion(Server); + end; + Status := nwqRefreshPrintJob(PrintJobData); + end; + end; + nwqGetPrintJob := Status + end; + +procedure OldEnumPrintJobs(Server : TnwServer; QID : nwLong; + EnumFunc : TnwEnumPrintJobFunc; + var ExtraData); + var + Status : word; + index : word; + Request : record + Len : word; + Func: byte; + Q : nwLong; + end; + StillEnumerating : boolean; + Reply : record + NumJobs : word; + JobList : array [1..250] of word; + end; + begin + with Request do + begin + Len := sizeof(Request) - 2; + Func := $6B; + Q := QID; + end; + Reply.NumJobs := 0; + Status := nwServerCall(Server, $17, + sizeof(Request), Request, sizeof(Reply), Reply); + if (Status = 0) and (Reply.NumJobs <> 0) then + begin + index := 0; + StillEnumerating := true; + while StillEnumerating and (index < Reply.NumJobs) do + begin + inc(index); + StillEnumerating := EnumFunc(Reply.JobList[index], ExtraData); + end; + end; + end; + +procedure NewEnumPrintJobs(Server : TnwServer; QID : nwLong; + EnumFunc : TnwEnumPrintJobFunc; + var ExtraData); + var + Status : word; + index : word; + LastPos: nwLong; + Request : record + Len : word; + Func: byte; + Q : nwLong; + SPos: nwLong; + end; + StillEnumerating : boolean; + Reply : record + TotJobs : nwLong; + NumJobs : nwLong; + JobList : array [1..125] of nwLong; + end; + begin + LastPos := 1; + StillEnumerating := true; + while StillEnumerating and (LastPos <> -1) do + begin + with Request do + begin + Len := sizeof(Request) - 2; + Func := $81; + Q := QID; + SPos := LastPos; + end; + Reply.NumJobs := 0; + Status := nwServerCall(Server, $17, + sizeof(Request), Request, + sizeof(Reply), Reply); + if (Status <> 0) then + StillEnumerating := false + else + if (Reply.NumJobs <> 125) then + LastPos := -1 + else + inc(LastPos, 125); + index := 0; + while StillEnumerating and (index < Reply.NumJobs) do + begin + inc(index); + StillEnumerating := EnumFunc(Reply.JobList[index], ExtraData); + end; + end; + end; + +procedure nwqEnumPrintJobs(Server : TnwServer; QueueName : TnwObjectStr; + EnumFunc : TnwEnumPrintJobFunc; + var ExtraData); + var + QID : nwLong; + begin + if (nwShellType <> nsNone) then + if (nwbGetObjectID(Server, NWboPrintQueue, QueueName, QID) = 0) then + if (nwServerVersion(Server) < ServerVersion311) then + OldEnumPrintJobs(Server, QID, EnumFunc, ExtraData) + else + NewEnumPrintJobs(Server, QID, EnumFunc, ExtraData); + end; + +end. diff --git a/src/wc_sdk/nwsema.pas b/src/wc_sdk/nwsema.pas new file mode 100644 index 0000000..e1546fa --- /dev/null +++ b/src/wc_sdk/nwsema.pas @@ -0,0 +1,267 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$B+,F-,I-,R-,S-,V-} + {$IFDEF CanAllowOverlays} + {$F+,O+,A-} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-,P-} + {$ENDIF} + {all other compiler options are 'don't care'} + + +{!!.51 Note: because of changes to NWBASE and because of errors in Novell's + Client API documentation, this unit has been drastically simplified. + Hence there are no more !!.51 markers} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit NWSema; + {-NetWare semaphore API calls} + +interface + +uses + {$IFDEF Windows} + {$IFDEF Ver80} + SysUtils, + {$ELSE} + Strings, + {$ENDIF} + {$ENDIF} + nwBase, + nwConn; + +const + {Semaphore error constants} + nwsErrInvValue = $7F21; {Negative initial value on open operation} + nwsErrInvName = $7F22; {Invalid semaphore name on open operation, eg null} + nwsErrInvHandle = $89FF; {Invalid semaphore handle passed to routine} + nwsErrTimeOut = $897F; {Timeout on nwDecSema} + nwsErrOverflow = $8901; {Overflow on nwIncSema} + +type + {A semaphore name string} + TnwSemaName = string[127]; + +function nwCloseSema(Server : TnwServer; Handle : nwLong) : TnwErrorCode; + {-Close a semaphore. + Notes: Server is the server's handle for the semaphore. + Handle must have been obtained from nwOpenSema. This + function decrements the open count for the semaphore, when it + reaches zero the semaphore is deleted. The function returns + 0 or nwsErrInvHandle.} + +function nwDecSema(Server : TnwServer; Handle : nwLong; + TimeOut : word) : TnwErrorCode; + {-Decrement the value of a semaphore. + Notes: Server is the ID of the server for the semaphore. + Handle must have been obtained from nwOpenSema. This + function decrements the value of the semaphore. If the result + is >= 0, the function returns 0. If negative, the + workstation is put in a queue until another workstation + increments the semaphore or TimeOut ticks go by. If the former + the function returns 0, if the latter it reincrements + the value and returns nwsErrTimeout. + Known in the Novell literature as WaitOnSemaphore} + +function nwExamineSema(Server : TnwServer; + Handle : nwLong; + var Value : nwInt; + var OpenCount : word) : TnwErrorCode; + {-Return the current value and the open count of a semaphore. + Notes: Server is the ID of the server for the semaphore. + Handle must have been obtained from nwOpenSema.} + +function nwIncSema(Server : TnwServer; Handle : nwLong) : TnwErrorCode; + {-Increment the value of a semaphore. + Notes: Server is the ID of the server for the semaphore. + Handle must have been obtained from nwOpenSema. If the + value of the semaphore is 127, this function returns immediately + with nwsErrOverflow, otherwise it adds 1 to the value and returns + with 0. + Known in the Novell literature as SignalSemaphore} + +function nwOpenSema(Server : TnwServer; + Name : TnwSemaName; + InitialValue : nwInt; + var OpenCount: word; + var Handle : nwLong) : TnwErrorCode; + {-Open or create a semaphore. + Notes: Server must be the server ID where the semaphore + resides or will reside when created. Name will label the semaphore + if it does not exist, or it is the (case insignificant) name of a + currently open semaphore. If the semaphore is being created + InitialValue must be in the range 0..127. The number of stations + (including the caller's) will be returned in OpenCount, and the + semaphore's handle which will be used in subsequent semaphore + calls will be returned in Handle. The function returns + 0, nwsErrInvName or nwsErrInvValue.} + +implementation + +type + LH = record L, H : word; end; {for splitting nwLong into hi/lo words} + OS = record O, S : word; end; {for splitting pointer into seg/sel & ofs} + +const + nwsErrTimeOut2 = $89FE; + +function nwCloseSema(Server : TnwServer; Handle : nwLong) : TnwErrorCode; + var + Request : record + Func : byte; + Hndl : nwLong; + end; + Dummy : byte; + begin + {API: Close Semaphore} + Request.Func := $04; + Request.Hndl := Handle; + nwCloseSema := nwServerCall(Server, $20, sizeof(Request), Request, + 0, Dummy); + end; + +function nwDecSema(Server : TnwServer; Handle : nwLong; + TimeOut : word) : TnwErrorCode; + var + Request : record + Func : byte; + Hndl : nwLong; + TOut : word; + end; + Dummy : byte; + Status : word; + begin + {API: Wait On Semaphore} + Request.Func := $02; + Request.Hndl := Handle; + Request.TOut := swap(TimeOut); + Status := nwServerCall(Server, $20, sizeof(Request), Request, 0, Dummy); + if (Status = nwsErrTimeOut2) then + Status := nwsErrTimeOut; + nwDecSema := Status; + end; + +function nwExamineSema(Server : TnwServer; + Handle : nwLong; + var Value : nwInt; + var OpenCount : word) : TnwErrorCode; + var + Request : record + Func : byte; + Hndl : nwLong; + end; + Reply : record + V : shortint; + O : byte; + end; + Status : word; + begin + {API: Examine Semaphore} + Request.Func := $01; + Request.Hndl := Handle; + Status := nwServerCall(Server, $20, sizeof(Request), Request, + sizeof(Reply), Reply); + if (Status = 0) then + begin + Value := Reply.V; + OpenCount := Reply.O; + end + else + begin + Value := 0; + OpenCount := 0; + end; + nwExamineSema := Status; + end; + +function nwIncSema(Server : TnwServer; Handle : nwLong) : TnwErrorCode; + var + Request : record + Func : byte; + Hndl : nwLong; + end; + Dummy : byte; + begin + {API: Signal Semaphore} + Request.Func := $03; + Request.Hndl := Handle; + nwIncSema := nwServerCall(Server, $20, sizeof(Request), Request, 0, Dummy); + end; + +function nwOpenSema(Server : word; + Name : TnwSemaName; + InitialValue : nwInt; + var OpenCount: word; + var Handle : nwLong) : TnwErrorCode; + var + Request : record + Func : byte; + Init : byte; + SNam : string; + end; + Reply : record + Hndl : nwLong; + Open : byte; + end; + Status : word; + begin + {API: Open Semaphore} + if (InitialValue < 0) or (InitialValue > 127) then + begin + nwOpenSema := nwsErrInvValue; + Exit; + end; + if (length(Name) = 0) then + begin + nwOpenSema := nwsErrInvName; + Exit; + end; + with Request do + begin + Func := $00; + Init := InitialValue; + SNam := Name; + nwUpperStr(SNam); + end; + Status := nwServerCall(Server, $20, sizeof(Request), Request, + sizeof(Reply), Reply); + if (Status = 0) then + begin + OpenCount := Reply.Open; + Handle := Reply.Hndl; + end; + nwOpenSema := Status; + end; + +end. diff --git a/src/wc_sdk/nwtts.pas b/src/wc_sdk/nwtts.pas new file mode 100644 index 0000000..99c6eb1 --- /dev/null +++ b/src/wc_sdk/nwtts.pas @@ -0,0 +1,279 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$B+,F-,I-,R-,S-,V-} + {$IFDEF CanAllowOverlays} + {$F+,O+,A-} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-,P-} + {$ENDIF} + {all other compiler options are 'don't care'} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit NWTTS; + {-Unit to provide NetWare TTS functionality.} + +{Note: major changes for 5.51 to support problem adapters.} + +interface + +uses + NWBase; + +function nwTTSAbort(Server : TnwServer) : TnwErrorCode; + {-Abort (rollback) the current transaction.} + +function nwTTSAvailable(Server : TnwServer) : Boolean; + {-Return true if TTS is available.} + +function nwTTSBegin(Server : TnwServer) : TnwErrorCode; + {-Start a new transaction.} + +function nwTTSDisable(Server : TnwServer) : Boolean; + {-Disable TTS. Returns true if TTS was successfully disabled.} + +function nwTTSEnable(Server : TnwServer) : Boolean; + {-Enable TTS. Returns true if TTS was successfully enabled.} + +function nwTTSEnd(Server : TnwServer; var ID : nwLong) : TnwErrorCode; + {-End (commit) the current transaction.} + +function nwTTSIsCommitted(Server : TnwServer; ID : nwLong) : Boolean; + {-Return true if transaction given by ID has been committed to disk.} + + +{---Extra TTS routines---} +procedure nwTTSGetAppThresh(Server : TnwServer; var Logical, Physical : byte); + {-Return the application's logical and physical lock threshold values + for implicit transaction tracking to begin.} + +procedure nwTTSGetWSThresh(Server : TnwServer; var Logical, Physical : byte); + {-Return the workstation's logical and physical lock threshold values + for implicit transaction tracking to begin.} + +function nwTTSSetAppThresh(Server : TnwServer; Logical, Physical : byte) : TnwErrorCode; + {-Set the application's logical and physical lock threshold values + for implicit transaction tracking to begin.} + +function nwTTSSetWSThresh(Server : TnwServer; Logical, Physical : byte) : TnwErrorCode; + {-Set the workstation's logical and physical lock threshold values + for implicit transaction tracking to begin.} + +implementation + +type + OS = record O, S : word; end; {!!.51} + + +function nwTTSAbort(Server : TnwServer) : TnwErrorCode; + var + Request : byte; + Dummy : byte; + begin + {API: TTS Abort Transaction} + Request := $03; + nwTTSAbort := nwServerCall(Server, $22, {!!.51} + sizeof(Request), Request, 0, Dummy); + end; + +function nwTTSAvailable(Server : TnwServer) : Boolean; + var + Request : byte; + Dummy : byte; + begin + {API: TTS Is Available} + Request := $00; + nwTTSAvailable := nwServerCall(Server, $22, {!!.51} + sizeof(Request), Request, 0, Dummy) = $89FF; + end; + +function nwTTSBegin(Server : TnwServer) : TnwErrorCode; + var + Request : byte; + Dummy : byte; + begin + {API: TTS Begin Transaction} + Request := $01; + nwTTSBegin := nwServerCall(Server, $22, {!!.51} + sizeof(Request), Request, 0, Dummy); + end; + +function nwTTSEnd(Server : TnwServer; var ID : nwLong) : TnwErrorCode; + var + Request : byte; + Reply : record + EndID : longint; + Dummy : byte; + end; + Status : word; + begin + {Note: it has been discovered that nwTTSEnd will only work + on some adapters if the reply packet is one more than + is really required. Rewritten for !!.51} + {API: TTS End Transaction} + Request := $02; + ID := 0; + FillChar(Reply, sizeof(Reply), 0); + Status := nwServerCall(Server, $22, {!!.51} + sizeof(Request), Request, + sizeof(Reply), Reply); + if (Status = 0) then + ID := Reply.EndID; + nwTTSEnd := Status; + end; + +function nwTTSIsCommitted(Server : TnwServer; ID : nwLong) : Boolean; + var + Status : word; + Request : record + Func : byte; + TTSID: nwLong; + end; + Dummy : byte; + begin + {API: TTS Transaction Status} + Request.Func := $04; + Request.TTSID := ID; + Status := nwServerCall(Server, $22, sizeof(Request), Request, {!!.51} + 0, Dummy); + nwTTSIsCommitted := (Status = 0); + end; + +function nwTTSDisable(Server : TnwServer) : Boolean; + var + Request : record + Len : word; + Func : byte; + end; + Dummy : byte; + begin + {API: Disable Transaction Tracking} + Request.Len := 1; + Request.Func := $CF; + nwTTSDisable := nwServerCall(Server, $17, sizeof(Request), Request, + 0, Dummy) = 0; {!!.51} + end; + +function nwTTSEnable(Server : TnwServer) : Boolean; + var + Request : record + Len : word; + Func : byte; + end; + Dummy : byte; + begin + {API: Enable Transaction Tracking} + Request.Len := 1; + Request.Func := $D0; + nwTTSEnable := nwServerCall(Server, $17, sizeof(Request), Request, + 0, Dummy) = 0; {!!.51} + end; + +{---Extra TTS routines---} +procedure nwTTSGetAppThresh(Server : TnwServer; var Logical, Physical : byte); + var + Reply : record + Log, Phy : byte; + end; + Request : byte; + begin + {API: TTS Get Application Thresholds} + Request := $05; + if nwServerCall(Server, $22, sizeof(Request), Request, {!!.51} + sizeof(Reply), Reply) = 0 then + begin + Logical := Reply.Log; + Physical := Reply.Phy; + end + else + begin + Logical := 0; + Physical := 0; + end + end; + +procedure nwTTSGetWSThresh(Server : TnwServer; var Logical, Physical : byte); + var + Reply : record + Log, Phy : byte; + end; + Request : byte; + begin + {API: TTS Get Workstation Thresholds} + Request := $07; + if nwServerCall(Server, $22, sizeof(Request), Request, {!!.51} + sizeof(Reply), Reply) = 0 then + begin + Logical := Reply.Log; + Physical := Reply.Phy; + end + else + begin + Logical := 0; + Physical := 0; + end + end; + +function nwTTSSetAppThresh(Server : TnwServer; Logical, Physical : byte) : TnwErrorCode; + var + Request : record + Func : byte; + Log, Phy : byte; + end; + Dummy : byte; + begin + {API: TTS Set Application Thresholds} + Request.Func := $06; + Request.Log := Logical; + Request.Phy := Physical; + nwTTSSetAppThresh := nwServerCall(Server, $22, sizeof(Request), Request, + 0, Dummy); {!!.51} + end; + +function nwTTSSetWSThresh(Server : TnwServer; Logical, Physical : byte) : TnwErrorCode; + var + Request : record + Func : byte; + Log, Phy : byte; + end; + Dummy : byte; + begin + {API: TTS Set Workstation Thresholds} + Request.Func := $08; + Request.Log := Logical; + Request.Phy := Physical; + nwTTSSetWSThresh := nwServerCall(Server, $22, sizeof(Request), Request, + 0, Dummy); {!!.51} + end; + +end. diff --git a/src/wc_sdk/oopsema.pas b/src/wc_sdk/oopsema.pas new file mode 100644 index 0000000..4050330 --- /dev/null +++ b/src/wc_sdk/oopsema.pas @@ -0,0 +1,307 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{$I btdefine.inc} +{$F-,V-,B-,S-,I-,R-} +{$IFDEF CanSetOvrflowCheck} + {$Q-,P-} +{$ENDIF} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit OopSema; + +interface + +uses + NWBase, + NWSema; + +type + PSemaphore = ^TSemaphore; + TSemaphore = object + {-An object that simply encapsulates the semaphore calls} + ssName : ^string; + ssHandle : nwLong; + ssServer : TnwServer; + ssError : word; + + constructor Init(Server : TnwServer; + Name : TnwSemaName; + InitialValue : nwInt); + {-Open a semaphore} + destructor Done; virtual; + {-Close a semaphore} + function GetLastError : word; + {-Return the last error} + function GetName : string; + {-Return the name of the semaphore} + function GetOpenCount : word; + {-Return the number of processes that have the semaphore open} + function GetValue : nwInt; + {-Return the current value of the semaphore} + procedure IncValue; + {-Increment the value of the semaphore} + procedure DecValue(TimeOut : word); + {-Decrement the value of the semaphore} + end; + + +type + SemaphoreRec = record + Sema : PSemaphore; + Valu : nwInt; + Cnt : word; + end; + +const + MaxSemaphores = 65520 div sizeof(SemaphoreRec); + +type + SemaphoreList = Array [1..MaxSemaphores] of SemaphoreRec; + + {This is a higher level semaphore object used to provide synchronization + between workstations. See TurboPower's FBDEMO for an example usage of this + object type.} + TFilerSemaphore = object + fsNrOfKeys : integer; + fsSemaphores : ^SemaphoreList; + constructor Init(Server : TnwServer; Name : String; NrOfKeys : integer); + {-create the semaphores} + destructor Done; Virtual; + {-destroy the semaphores} + procedure IndicateDirty(KeyNr : integer); + {-Indicate to others that a file has been modified} + function IsDirty(KeyNr : integer) : boolean; + {-see if the file has been modified} + function NumberOpen(KeyNr : integer) : word; + {-Return the number of stations currently using the semaphore} + end; + +implementation + +constructor TSemaphore.Init(Server : TnwServer; + Name : TnwSemaName; + InitialValue : nwInt); + var + Result : word; + OpenCount : word; + + begin + Result := nwOpenSema(Server, Name, InitialValue, + OpenCount, ssHandle); + if (Result <> 0) then + Fail; + ssServer := Server; + + if not nwGetMem(ssName, succ(length(Name))) then + begin + Done; + Fail; + end; + ssName^ := Name; + ssError := 0; + end; + +destructor TSemaphore.Done; + begin + if (ssName <> nil) then + FreeMem(ssName, succ(length(ssName^))); + ssError := nwCloseSema(ssServer, ssHandle); + end; + +function TSemaphore.GetLastError : word; + begin + GetLastError := ssError; + ssError := 0; + end; + +function TSemaphore.GetName : string; + begin + if (ssName <> nil) then + GetName := ssName^ + else GetName := ''; + end; + +function TSemaphore.GetOpenCount : word; + var + Value : nwInt; + OpenCount : word; + begin + GetOpenCount := 0; + if (ssError = 0) then + begin + ssError := nwExamineSema(ssServer, ssHandle, Value, OpenCount); + if (ssError = 0) then + GetOpenCount := OpenCount; + end; + end; + +function TSemaphore.GetValue : nwInt; + var + Value : nwInt; + OpenCount : word; + begin + GetValue := 0; + if (ssError = 0) then + begin + ssError := nwExamineSema(ssServer, ssHandle, Value, OpenCount); + if (ssError = 0) then + GetValue := Value; + end; + end; + +procedure TSemaphore.IncValue; + begin + if (ssError = 0) then + ssError := nwIncSema(ssServer, ssHandle); + end; + +procedure TSemaphore.DecValue(TimeOut : word); + begin + if (ssError = 0) then + ssError := nwDecSema(ssServer, ssHandle, TimeOut); + end; + + + + +function IntToStr(I : Integer) : String; + var + S : string[11]; + begin + Str(I, S); + IntToStr := S; + end; + +constructor TFilerSemaphore.Init(Server : TnwServer; + Name : string; + NrOfKeys : integer); + var + i : integer; + Size : word; + begin + if (NrOfKeys < 1) or (NrOfKeys > MaxSemaphores) then + Fail; + + Size := NrOfKeys * SizeOf(SemaphoreRec); + if not nwGetMem(fsSemaphores, Size) then + Fail; + FillChar(fsSemaphores^, Size, 0); + fsNrOfKeys := NrOfKeys; + + for i := 1 to NrOfKeys do + with fsSemaphores^[I] do + begin + if not nwGetMem(Sema, sizeof(TSemaphore)) then + begin + Done; + Fail; + end; + Sema^.Init(Server, 'fs__'+Name+IntToStr(i), 0); + with Sema^ do + begin + Valu := GetValue; + Cnt := GetOpenCount; + if (GetLastError <> 0) then + begin + Done; + Fail; + end; + end; + end; + end; + +destructor TFilerSemaphore.Done; + var + i : integer; + begin + if (fsSemaphores <> nil) then + begin + for i := 1 to fsNrOfKeys do + with fsSemaphores^[i] do + if (Sema <> nil) then + Dispose(Sema, Done); + FreeMem(fsSemaphores, fsNrOfKeys * sizeof(SemaphoreRec)); + end; + end; + +procedure TFilerSemaphore.IndicateDirty(KeyNr : Integer); + var + i : integer; + begin + if (1 <= KeyNr) and (KeyNr <= fsNrOfKeys) then + with fsSemaphores^[KeyNr], Sema^ do + begin + IncValue; + if (GetLastError = nwsErrOverflow) then + begin + for i := 127 downto 1 do + DecValue(0); + if (GetLastError = nwsErrTimeout) then + {nothing}; + end; + Valu := GetValue; + Cnt := GetOpenCount; + if (GetLastError <> 0) then + {nothing}; + end; + end; + +function TFilerSemaphore.IsDirty(KeyNr : Integer) : Boolean; + var + CurValue : nwInt; + begin + IsDirty := False; + if (1 <= KeyNr) and (KeyNr <= fsNrOfKeys) then + with fsSemaphores^[KeyNr], Sema^ do + begin + CurValue := GetValue; + if (GetLastError = 0) and + (CurValue <> Valu) then + begin + IsDirty := true; + Valu := CurValue; + end; + end; + end; + +function TFilerSemaphore.NumberOpen(KeyNr : Integer) : word; + begin + NumberOpen := 0; + if (1 <= KeyNr) and (KeyNr <= fsNrOfKeys) then + with fsSemaphores^[KeyNr], Sema^ do + begin + Cnt := GetOpenCount; {!!.52} + if GetLastError = 0 then + NumberOpen := Cnt; + end; + end; + +end. diff --git a/src/wc_sdk/opbrow.pas b/src/wc_sdk/opbrow.pas new file mode 100644 index 0000000..67dfe5e --- /dev/null +++ b/src/wc_sdk/opbrow.pas @@ -0,0 +1,1524 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + + {-Compiler options} + {$I brdefopt.inc} + {$I opdefine.inc} + {$I-,V-,R-,F+,O+} {-overwrites user defined options + and must not be changed} + + +Unit OPBrow; + +Interface + +Uses + Dos, +{$IFDEF OPRO12} {!! 1.20} + OPConst, +{$ENDIF} + OPDos, + OpString, + OpInline, + OpRoot, + OpCrt, +{$IFDEF UseMouse} + OpMouse, +{$ENDIF} + OpCmd, + OpFrame, + OpWindow, +{$IFDEF UseDrag} + OpDrag, +{$ENDIF} +{$IFDEF BrUseShell} + OPSBase, + OOPShell, +{$ENDIF} +{$IFDEF BrUseIsam} + BTBase, + BTIsBase, + Filer, {!!.TP} +{$ENDIF} + LowBrows, + MedBrows, + HiBrows; + +{$I opbrow.icd} {configuration data} + +Const + ucOPBrowse = 99; { Unitcode } + + lwSelectOnClick = $0001; {implicit Enter for mouse click on browser bar} + lwSuppressUpdate = $0002; {No background update } + DefOPBrOptions : Word = lwSelectOnClick; + BadOPBrOptions : Word = 0; + +Type + ISBrowserPtr = ^ISBrowser; + LowWinBrowserPtr = ^LowWinBrowser; + + LowWinBrowser = Object ( BRHBrowser ) + Owner : ISBrowserPtr; + + Constructor Init ( AOwner : ISBrowserPtr; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + ALKey, + AHKey : GenKeyStr; + ASaveStat : Boolean; + Var ADatS; + AIsVarRec : Boolean ); + + Destructor Done; Virtual; + + Function PreCompletePage : Integer; Virtual; + + Function PostCompletePage : Integer; Virtual; + + Function BuildRow ( Var RR : RowRec ) : Integer; Virtual; + + Function PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; Virtual; + + Procedure ShowErrorOccured ( Class : Integer ); Virtual; + End; + + + ISBrowser = Object ( CommandWindow ) + PBrowser : LowWinBrowserPtr; + lwOptions : Word; {option flags} + lwFullPage, + lwSaveFullPage, + lwMaxHorizOfs, + lwFirstRow, + lwVertScale : Word; + lwHorizOfs : Integer; + + lwDimColor : Byte; + lwDimMono : Byte; + lwHighlightColor : Byte; + lwHighlightMono : Byte; + lwHeaderFooterColor : Byte; + lwHeaderFooterMono : Byte; + + lwHeader, + lwFooter : BRLRowEltString; + lwUpdateInterval : Word; + + {$IFDEF BrUseIsam} + Constructor Init ( X1, Y1, X2, Y2 : Byte; + AFileBlockPtr : IsamFileBlockPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + Var ADatS; + AIsVarRec : Boolean ); + {-Initialize ISBrowser} +{$ENDIF} +{$IFDEF BrUseShell} + Constructor Init ( X1, Y1, X2, Y2 : Byte; + ADrvPtr : IFDriverPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString ); + {-Initialize ISBrowser} +{$ENDIF} + +{$IFDEF BrUseIsam} + Constructor InitCustom ( X1, Y1, X2, Y2 : Byte; + Var Colors : ColorSet; + AFileBlockPtr : IsamFileBlockPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + Var ADatS; + AIsVarRec : Boolean; + WinOptions : LongInt ); + + {-Initialize ISBrowser with custom colors and options} +{$ENDIF} +{$IFDEF BrUseShell} + Constructor InitCustom ( X1, Y1, X2, Y2 : Byte; + Var Colors : ColorSet; + ADrvPtr : IFDriverPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + WinOptions : LongInt ); + {-Initialize ISBrowser with custom colors and options} +{$ENDIF} + + Destructor Done; Virtual; + {-Dispose of browser} + Procedure UpdateContents; Virtual; + {-Redraw the browser} + Procedure ProcessSelf; Virtual; + {-Process browse commands} + Procedure AdjustWindow ( X1, Y1, X2, Y2 : Word ); Virtual; + {-Set new coordinates and adjust all related structures} + Procedure DisplayRow ( I : Integer; + Inverse : Boolean); + {-Display on row of browser} + Function PreCompletePage : Integer; Virtual; + {-Hook to be called before a page is build} + Function PostCompletePage : Integer; Virtual; + {-Hook to be called after a page is build} + Procedure ProcessPostCommand; Virtual; + {-Call user defineable routine after handling of keyboard or + mouse event } + Procedure ProcessPreCommand; Virtual; + {-Call user defineable routine prior to getting keyboard and mouse + events } + Function BuildRow ( Var RR : RowRec ) : Integer; Virtual; + {-Method to build one row; must be overridden} + Function PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; Virtual; + {-Record filtering function} + Procedure ShowErrorOccured ( Class : Integer ); Virtual; + {-Hook to be called if error occurs} + Procedure CharHandler; Virtual; + {-Call user defineable routine to position browser} + Procedure lwOptionsOn ( OptionFlags : Word ); + {-Activate multiple options} + Procedure lwOptionsOff ( OptionFlags : Word ); + {-Deactivate multiple options} + Function lwOptionsAreOn ( OptionFlags : Word ) : Boolean; + {-Return true if all specified options are on} + Procedure SetDimAttr ( Color, Mono : Byte ); + {-Set attributes for dim characters} + Procedure SetHighlightAttr ( Color, Mono : Byte ); + {-Set attributes for highlighted characters} + Procedure SetHeaderFooterAttr ( Color, Mono : Byte ); + {-Set attributes for Header characters} + Procedure SetHeaderFooter ( AHeader, AFooter : BRLRowEltString ); + {-Change header and footer} + Procedure SetAndUpdateBrowserScreen ( NewKeyStr : GenKeyStr; + NewRef : LongInt ); + {-Set new current row and update the browser screen} + Procedure UpdateBrowserScreen; + {-Update the browser screen} + Function GetThisRec ( Var RR : RowRec ) : Integer; + {-Get the record defined by RR} + Function GetCurrentRec ( Var Match : Boolean ) : Integer; {mod !!.03} + {-Get the current record} + Function GetCurrentKeyNr : Word; + {-Get the current key number} + Function GetCurrentKeyStr : String; + {-Get the key related to the current record} + Function GetCurrentDatRef : LongInt; + {-Get the record number of the current record} + Procedure SetKeyNr ( Value : Word ); + {-Switch to index Value} + Function GetBrowseStatus : Boolean; Virtual; + {-get status of browser} + Function BuildBrowScreenRow ( Var RR : RowRec ) : Integer; + {-Build row for record defined by RR} + Procedure SetLowHighKey ( ALowKey, AHighKey : GenKeyStr ); + {-Set LowKey and HighKey} + Procedure SetUpdateInterval ( IV : Word ); + {-Update browser screen every IV mseconds} + {+++++++++ following methods for internal use only +++++++} + Function lwAdjustHorizOfs ( Delta : Integer) : Integer; + Procedure lwReinit; + Procedure lwLineDown; + Procedure lwLineUp; + Procedure lwPageDown; + Procedure lwPageUp; + Procedure lwFirstPage; + Procedure lwLastPage; + Procedure lwMoveToRelPos ( Pos : Word ); + Procedure lwLineRight; + Procedure lwLineLeft; + Procedure lwPageRight; + Procedure lwPageLeft; + Procedure lwLeftHome; + Procedure lwRightHome; + Procedure lwMoveToHorizPos ( Pos : Word ); + + + Function lwMustUpdateScreen : Boolean; Virtual; + Procedure lwDrawLinePrim ( S : String; Row : Byte; A : Byte ); + {$IFDEF UseScrollBars} + Procedure lwSetupForScrollBars; + Procedure lwUpdateVertScrollBar; + Procedure lwUpdateHorzScrollBar; + {$ENDIF} + {$IFDEF UseMouse} + Function lwProcessMouseCommand ( Var ibCmd : Word ) : Boolean; + {$IFDEF UseDrag} + Procedure lwClearMouseAutoEvents; + {$ENDIF} + {$ENDIF} + End; + +Var + {$IFDEF UseDrag} + OpBrCommands : DragProcessor; + {$ELSE} + OpBrCommands : CommandProcessor; + {$ENDIF} + + {===========================================================} + +Implementation + + Const + VertScrollScale = 63; + + Constructor LowWinBrowser.Init + ( AOwner : ISBrowserPtr; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + ALKey, + AHKey : GenKeyStr; + ASaveStat : Boolean; + Var ADatS; + AIsVarRec : Boolean ); + + Begin + Owner := AOwner; + If Not BRHBrowser.Init ( ADrvOrFileBlockPtr, ANumberOfEltsPerRow, + ANumberOfRows, ALKey, AHKey, ASaveStat, ADatS, AIsVarRec ) Then Fail; + End; + + + Destructor LowWinBrowser.Done; + + Begin + BRHBrowser.Done; + Owner := Nil; + End; + + + Function LowWinBrowser.PreCompletePage : Integer; + + Begin + PreCompletePage := Owner^.PreCompletePage; + End; + + + Function LowWinBrowser.PostCompletePage : Integer; + + Begin + PostCompletePage := Owner^.PostCompletePage; + End; + + + Function LowWinBrowser.BuildRow ( Var RR : RowRec ) : Integer; + + Begin + BuildRow := Owner^.BuildRow ( RR ); + End; + + + Function LowWinBrowser.PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; + + Begin + PerFormFilter := Owner^.PerformFilter ( RR, UseIt ); + End; + + + Procedure LowWinBrowser.ShowErrorOccured ( Class : Integer ); + + Begin + Owner^.ShowErrorOccured ( Class ); + End; + + + {$IFDEF BrUseIsam} + Constructor ISBrowser.Init ( X1, Y1, X2, Y2 : Byte; + AFileBlockPtr : IsamFileBlockPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + Var ADatS; + AIsVarRec : Boolean ); + {-Initialize ISBrowser} + Begin + If Not ISBrowser.InitCustom ( X1, Y1, X2, Y2, + DefaultColorSet, + AFileBlockPtr, + ANumberOfEltsPerRow, + ANumberOfRows, + AKeyNr, + ALKey, + AHKey, + AHeader, + AFooter, + ADatS, + AIsVarRec, + DefWindowOptions ) Then Fail; + End; +{$ENDIF} + +{$IFDEF BrUseShell} + Constructor ISBrowser.Init ( X1, Y1, X2, Y2 : Byte; + ADrvPtr : IFDriverPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString ); + {-Initialize ISBrowser} + Begin + If Not ISBrowser.InitCustom ( X1, Y1, X2, Y2, + DefaultColorSet, + ADrvPtr, + ANumberOfEltsPerRow, + ANumberOfRows, + AKeyNr, + ALKey, + AHKey, + AHeader, + AFooter, + DefWindowOptions ) Then Fail; + End; +{$ENDIF} + +{$IFDEF BrUseIsam} + Constructor ISBrowser.InitCustom ( X1, Y1, X2, Y2 : Byte; + Var Colors : ColorSet; + AFileBlockPtr : IsamFileBlockPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + Var ADatS; + AIsVarRec : Boolean; + WinOptions : LongInt ); + + {-Initialize ISBrowser with custom colors and options} +{$ENDIF} + +{$IFDEF BrUseShell} + Constructor ISBrowser.InitCustom ( X1, Y1, X2, Y2 : Byte; + Var Colors : ColorSet; + ADrvPtr : IFDriverPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + WinOptions : LongInt ); + {-Initialize ISBrowser with custom colors and options} + +Var + Dummy : Pointer; +{$ENDIF} + + Var + PLW : LowWinBrowserPtr; + Changed : Boolean; + + Begin + {--Bind the objects} +{$IFDEF BrUseIsam} + New ( PLW, Init ( @Self, AFileBlockPtr, ANumberOfEltsPerRow, + ANumberOfRows, ALKey, AHKey, True, ADatS, AIsVarRec ) ); +{$ENDIF} + +{$IFDEF BrUseShell} + Dummy := Nil; + New ( PLW, Init ( @Self, ADrvPtr, ANumberOfEltsPerRow, + ANumberOfRows, ALKey, AHKey, False, Dummy, False ) ); +{$ENDIF} + If PLW = Nil Then Begin + InitStatus := epFatal + ecOutOfMemory; + Fail; + End; + If Not CommandWindow.InitCustom ( X1, Y1, X2, Y2, Colors, WinOptions, + OpBrCommands, ucOPBrowse ) Then Begin + {-Done already virtually called by RawWindow} + Fail; + End; + + lwOptions := DefOpBrOptions; + + PBrowser := PLW; + PBrowser^.KeyNr := AKeyNr; + lwHorizOfs := 0; + lwHeader := AHeader; + lwFooter := AFooter; + + lwReinit; + lwVertScale := VertScrollScale; + + {$IFDEF UseScrollBars} + lwSetupForScrollbars; + {$ENDIF} + + PBrowser^.SetNrOfRows ( lwFullPage ); + + lwUpdateInterval := 0; + + {initialize our own data fields} + + {set video attributes} + lwDimColor := Colors.TextColor; + lwDimMono := Colors.TextMono; + lwHighlightColor := Colors.HighlightColor; + lwHighlightMono := Colors.HighlightMono; + lwHeaderFooterColor := Colors.HeaderColor; + lwHeaderFooterMono := Colors.HeaderMono; + SetCursor ( cuHidden ); + InitStatus := 0; + End; + + + Destructor ISBrowser.Done; + + Begin + If PBrowser <> Nil Then Dispose ( PBrowser, Done ); + CommandWindow.Done; + End; + + + Procedure ISBrowser.lwDrawLinePrim ( S : string; Row : Byte; A : Byte ); + + Begin + wFastWrite ( S, Row, 1, A ); + End; + + + Procedure ISBrowser.DisplayRow ( I : Integer; + Inverse : Boolean); + Var + S : String; + + Procedure WriteStringOut ( S : String; LineNr : Word; Color : Byte ); + + Var + Y : Word; + S1 : String; + A : Byte; + + Begin + Case Color Of + 1 : A := ColorMono ( lwHeaderFooterColor, lwHeaderFooterMono ); + 2 : A := ColorMono ( lwDimColor, lwDimMono ); + 3 : A := ColorMono ( lwHighLightColor, lwHighLightMono ); + End; + S1 := S; + FillChar ( S1, 255 , 32 ); + S1 := Copy ( S, Succ ( lwHorizOfs ), 255); + S1 [0] := #255; + Y := ( LineNr + lwFirstRow - 1 ); + lwDrawLinePrim ( S1, Y, A ); + End; + + + Begin + If I = 1 Then Begin + If ( lwHeader <> '' ) Or ( lwFooter <> '' ) Then Begin + If lwHeader <> '' Then Begin + WriteStringOut ( lwHeader, 0, 1 ); + End; + If lwFooter <> '' Then Begin + WriteStringOut ( lwFooter, Succ ( lwFullPage ), 1 ); + End; + End; + End; + + With PBrowser^, BSAPtr^[I]^ Do Begin + S := Row; + End; + If Inverse Then + WriteStringOut ( S, I, 3 ) + Else + WriteStringOut ( S, I, 2 ); + End; + + + Procedure ISBrowser.UpDateContents; + + Var + I : Word; + CR : Word; + + Begin + If PBrowser <> Nil Then Begin + CR := PBrowser^.GetCurRow; + For I := 1 To lwFullPage Do Begin + DisplayRow ( I, I = CR); + End; + End; + StackWindow.UpdateContents; + End; + + + Procedure ISBrowser.AdjustWindow ( X1, Y1, X2, Y2 : Word ); + Var + D : Integer; + Begin + D := ( wYH - wYL ); + CommandWindow.AdjustWindow ( X1, Y1, X2, Y2 ); + D := ( wYH - wYL ) - D; + IF D <> 0 Then Begin + lwReInit; + If D > 0 Then PBrowser^.HExpandPage ( lwFullPage ) Else + If D < 0 Then PBrowser^.HShrinkPage ( lwFullpage ); + End; + If IsCurrent Then UpdateContents; + End; + + + + + Procedure ISBrowser.ProcessSelf; + {-Process browse commands} + + Var + Finished : Boolean; + + Begin + {$IFDEF UseScrollBars} + {--Make sure we're set up for scroll bars} + lwSetupForScrollBars; + {$ENDIF} + {check for pending error} + cwCmd := ccError; + If cwGetLastError <> 0 Then + Exit; + + {Clear any other errors as well} + ClearErrors; + + {Draw initial screen if not already done} + Draw; + If (RawError <> 0) Or (cwGetLastError <> 0) Then Begin + Exit; + End; + + Repeat + {--Get the next command} + Finished := False; + ProcessPreCommand; + If lwMustUpdateScreen Then Begin + SetLastCommand ( bcUpdate ) + End Else Begin + GetNextCommand; + End; + {$IFDEF UseMouse} + If cwCmd in [ ccMouseSel, {Mouse selection - left button up} + ccMouseDown, {Mouse left button down} + ccMouseAuto ] Then {Mouse moved with left down or autorepeat} + Begin + Finished := lwProcessMouseCommand ( cwCmd ); + End; + {$ENDIF} + + Case cwCmd Of + ccNone : ; + ccChar : CharHandler; + ccError : Begin + Finished := True; + End; + ccUp : lwLineUp; + ccDown : lwLineDown; + ccPageUp : lwPageUp; + ccPageDn : lwPageDown; + ccTopOfFile : lwFirstPage; + ccEndOfFile : lwLastPage; + ccLeft : lwLineLeft; + ccRight : lwLineRight; + ccWordLeft : lwPageLeft; + ccWordRight : lwPageRight; + ccHome : lwLeftHome; + ccEnd : lwRightHome; + ccHelp : RequestHelp ( wHelpIndex ); + bcUpdate : UpdateBrowserScreen; + ccSelect, + ccQuit, + ccUser0..ccUser65335 : + Finished := True; + + Else If ( cwCmd <= 255 ) And ( GetExitCommandPtr <> Nil ) Then Begin + Finished := ( cwCmd In GetExitCommandPtr^ ); + End; + End; {Case} + ProcessPostCommand; + Until Finished; + rwSaveWindowState; + {-Save window state} + End; + + Procedure ISBrowser.CharHandler; + + Begin + End; + + + Procedure ISBrowser.SetUpdateInterval ( IV : Word ); + Begin + lwUpdateInterval := IV; + End; + + + Function ISBrowser.lwMustUpdateScreen : Boolean; + var + T : LongInt; + Begin + lwMustUpdateScreen := False; +{$IFDEf BRUseShell} + If ( IFDNetSupported = Nonet ) Or +{$ENDIF} +{$IFDEf BRUseIsam} + If ( BTNetSupported = Nonet ) Or +{$ENDIF} + ( lwUpdateInterval = 0 ) Or + ( lwOptionsAreOn ( lwSuppressUpdate )) Then Exit; + T := TimeMS; + {wait until key pressed} + While Not cwCmdPtr^.cpKeyPressed Do Begin + {is it time to check again?} + If ( TimeMS - T ) >= lwUpdateInterval Then Begin + lwMustUpdateScreen := True; + Exit; + End; + End; + End; + + + Procedure ISBrowser.SetLowHighKey ( ALowKey, AHighKey : GenKeyStr ); + + Begin + With PBrowser^ Do Begin + LowKey := ALowKey; + HighKey := AHighKey; + End; + End; + + +{$IFDEF UseScrollBars} + Procedure ISBrowser.lwSetupForScrollBars; + {-Set boundaries for all scroll bars} + Begin + ChangeAllScrollBars ( 0, lwMaxHorizOfs, 0, lwVertScale ); + End; +{$ENDIF} + + Procedure ISBrowser.lwReinit; + {-Initialize variables that can change if window is resized} + + Var + MaxWidth, + AWidth : Word; + + Begin + lwFullPage := Succ ( wYH - wYL ); + lwFirstRow := 1; + If Trim ( lwHeader ) <> '' Then Begin + Dec (lwFullPage); + Inc (lwFirstRow); + End; + If Trim ( lwFooter ) <> '' Then Dec (lwFullPage); + AWidth := Succ ( wXH - wXL ); + MaxWidth := MaxCols; + If AWidth > MaxWidth Then Begin + lwMaxHorizOfs := 0; + End Else Begin + lwMaxHorizOfs := MaxWidth - AWidth; + End; + + {$IFDEF UseScrollBars} + lwSetupForScrollBars; + {$ENDIF} + End; + + + +{$IFDEF UseMouse} + {$IFDEF UseDrag} + Procedure ISBrowser.lwClearMouseAutoEvents; + Var + EventT, QH : Word; + X,Y : Byte; + Begin + Repeat + If Not MouseEventsPending Then Exit; + QH := PeekMouseEvent ( X, Y ); + If QH <> MouseLftAuto Then Exit; + QH := ReadMouseEvent ( X, Y ); + Until True; + End; +{$ENDIF} + + Function ISBrowser.lwProcessMouseCommand ( Var ibCmd : Word ) + : Boolean; + {-Process ccMouseSel command. Returns True to return control to user.} + Const + LastMouseDown : Integer = 0; + Var + L : LongInt; + FramePos : FramePosType; + HotCode, + Y : Byte; + Dragging : Boolean; + AllDone : Boolean; + OldCurRow : Integer; + + Begin + lwProcessMouseCommand := False; + AllDone := False; + OldCurrow := PBrowser^.GetCurrow; + + {determine position of mouse} + L := cwMouseResults ( ibCmd, FramePos, HotCode ); + + {Should mouse event be ignored?} + if cwIgnoreMouseEvent(Dragging, ibCmd, FramePos, HotCode) then Begin + If ( ibCmd = ccMouseSel ) Then + lwProcessMouseCommand := True; + ibCmd := ccNone; + LastMouseDown := 0; + Exit; + End; + + if HotCode = hsNone then begin + {Not a hot spot} + if FramePos = frInsideActive then begin + {Inside active window} + If ibCmd in [ ccMouseSel, ccMouseDown, ccMouseAuto ] Then Begin + With PBrowser^ Do Begin + Y := MouseKeyWordY + MouseYLo - wYL + 1; + If ibCmd = ccMouseDown Then + LastMouseDown := GetCurRow; + If ( ( Y = 1 ) And ( Trim ( lwHeader ) > '') ) + Or ( ( Y = Succ (wYH - wYL) ) And ( Trim ( lwFooter ) > '') ) + Then Begin + If ibCmd = ccMouseSel Then ibCMD := ccNone; + End Else Begin + Y := Y + 1 - lwFirstRow; + PBrowser^.SetCurRow ( Y ); + If ( OldCurRow <> PBrowser^.GetCurRow ) And + ( PBrowser^.GetCurRow <> 0 ) Then Begin + DisplayRow ( OldCurRow, False ); + DisplayRow ( PBrowser^.GetCurRow, True ); + lwUpDateVertScrollBar; + End Else Begin + If ( ibCmd = ccMouseSel ) Then Begin + If ( GetCurRow = LastMouseDown ) And + ( LastMouseDown <> 0 ) And + ( lwOptionsAreOn ( lwSelectOnClick )) Then Begin + ibCmd := ccSelect; + End; + End; + End; + End; + End; + AllDone := ( ibCmd = ccSelect ) Or AllDone; + End; + + End else if ( not Dragging ) or ( ibCmd = ccMouseDown ) Then Begin + {Button was pressed outside of active window, not on a hot spot} + If LongFlagIsSet ( wFlags, wAllMouseEvents ) Then Begin + AllDone := True; + End Else Begin + AllDone := False; + End; + End; + End; + + Case HotCode Of + hsNone :; {not a hot spot, do nothing} + {$IFDEF UseScrollBars} + hsDecV : Begin {the decrement fixture of a vertical scroll bar} + If ibCMD = ccMouseSel Then + ibCMD := ccNone + Else + ibCMD := ccUp; + End; + hsDecH : Begin {the decrement fixture of a horizontal scroll bar} + If ibCMD = ccMouseSel Then + ibCMD := ccNone + Else + ibCmd := ccLeft; + End; + hsIncV : Begin {the increment fixture of a vertical scroll bar} + If ibCMD = ccMouseSel Then + ibCMD := ccNone + Else + ibCmd := ccDown; + End; + hsIncH : Begin {the increment fixture of a horizontal scroll bar} + If ibCMD = ccMouseSel Then + ibCMD := ccNone + Else + ibCmd := ccRight; + End; + hsBar : Begin {the slider portion of a scroll bar} + Case FramePos Of + frLL, frRR : Begin {vertical scroll bar} + L := TweakSlider ( FramePos, MouseKeyWordY+MouseYLo, L, 1 ); + lwMoveToRelPos ( L ); + + End; + Else Begin {horizontal scroll bar} + With PBrowser^ Do Begin + L := TweakSlider ( FramePos, MouseKeyWordX+MouseXLo, L, 1 ); + lwMoveToHorizPos ( L ); + End; + AllDone := False; + End; + End; + ibCmd := ccNone; + End; + {$ENDIF} + hsSpot, {a single character hot spot} + hsRegion0..255 : Begin {a user-defined region relative to a frame} + AllDone := True; + End; + End; {Case} + {$IFDEF UseDrag} + lwClearMouseAutoEvents; + {$ENDIF} + lwProcessMouseCommand := AllDone; + End; +{$ENDIF} + + + Procedure ISBrowser.lwOptionsOn ( OptionFlags : Word ); + {-Activate multiple options} + Begin + lwOptions := lwOptions Or ( OptionFlags And Not BadOPBrOptions ); + End; + + + Procedure ISBrowser.lwOptionsOff ( OptionFlags : Word ); + {-Deactivate multiple options} + Begin + lwOptions := lwOptions And Not ( OptionFlags And Not BadOPBrOptions ); + End; + + + Function ISBrowser.lwOptionsAreOn ( OptionFlags : Word ) : Boolean; + {-Return true if all specified options are on} + Begin + lwOptionsAreOn := lwOptions And OptionFlags = OptionFlags; + End; + + + Procedure ISBrowser.SetDimAttr ( Color, Mono : Byte ); + {-Set attributes for dim characters} + Begin + lwDimColor := Color; + lwDimMono := MapMono ( Color, Mono ); + End; + + + Procedure ISBrowser.SetHighlightAttr ( Color, Mono : Byte ); + {-Set attributes for highlighted characters} + Begin + lwHighlightColor := Color; + lwHighlightMono := MapMono ( Color, Mono ); + End; + + + Procedure ISBrowser.SetHeaderFooterAttr ( Color, Mono : Byte ); + {-Set attributes for Header characters} + Begin + lwHeaderFooterColor := Color; + lwHeaderFooterMono := MapMono ( Color, Mono ); + End; + + + Procedure ISBrowser.SetHeaderFooter ( AHeader, AFooter + : BRLRowEltString ); + + Var + OldNrOfRows : Word; + + Begin + lwHeader := AHeader; + lwFooter := AFooter; + If PBrowser = Nil Then Exit; + OldNrOfRows := lwFullPage; + lwReinit; + With PBrowser^ Do Begin + If OldNrOfRows > lwFullPage Then Begin + HShrinkPage ( lwFullPage ); + End Else Begin + If OldNrOfRows < lwFullPage Then Begin + HExpandPage ( lwFullPage ); + End; + End; + If IsCurrent Then UpdateContents; + End; + End; + + Function ISBrowser.PreCompletePage : Integer; + + Begin + PreCompletePage := NoError; + End; + + Function ISBrowser.PostCompletePage : Integer; + + Begin + PostCompletePage := NoError; + End; + + Function ISBrowser.BuildRow ( Var RR : RowRec ) : Integer; + + Begin + Abstract; + End; + + Function ISBrowser.PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; + + Begin + UseIt := True; + PerformFilter := NoError; + End; + + Procedure ISBrowser.ShowErrorOccured ( Class : Integer ); + + Begin + End; + + + Procedure ISBrowser.ProcessPostCommand; + + Begin + End; + + + Procedure ISBrowser.ProcessPreCommand; + + Begin + End; + + + Procedure ISBrowser.SetAndUpdateBrowserScreen ( NewKeyStr : GenKeyStr; + NewRef : LongInt ); + + Begin + With PBrowser^ Do Begin + HBuildNewPage ( KeyNr, NewKeyStr, NewRef, GetCurRow, NrOfRows ); + If IsCurrent Then UpdateContents; +{$IFDEF UseScrollBars} + If StatusOK Then Begin + lwUpdateVertScrollBar; + lwUpdateHorzScrollBar; + End; +{$ENDIF} + End; + End; + + Procedure ISBrowser.UpdateBrowserScreen; + + Var + Changed : Boolean; + + Begin + With PBrowser^ Do Begin + HBuildThisPage ( Changed ); + If Changed Then Begin + If IsCurrent Then UpdateContents; +{$IFDEF UseScrollBars} + If StatusOK Then lwUpdateVertScrollBar; +{$ENDIF} + End; + End; + End; + + Function ISBrowser.GetCurrentRec ( Var Match : Boolean ) : Integer; {mod !!.03} + + Var + Result : Integer; + + Begin + With PBrowser^ Do Begin + Result := GetRowMatchingRec ( BSAPtr^[GetCurRow]^, True, True, + Match ); + End; + GetCurrentRec := Result; + End; + + + Function ISBrowser.GetThisRec ( Var RR : RowRec ) : Integer; + + Begin + GetThisRec := PBrowser^.BRGetRec ( RR, False, False ); + End; + + + Function ISBrowser.GetCurrentKeyNr : Word; + + Begin + GetCurrentKeyNr := PBrowser^.KeyNr; + End; + + + Function ISBrowser.GetCurrentKeyStr : String; + + Begin + GetCurrentKeyStr := PBrowser^.GetCurrentKeyStr; + End; + + + Function ISBrowser.GetCurrentDatRef : LongInt; + + Begin + GetCurrentDatRef := PBrowser^.GetCurrentDatRef; + End; + + + Procedure ISBrowser.SetKeyNr ( Value : Word ); + + Begin + PBrowser^.KeyNr := Value; + End; + + Function ISBrowser.GetBrowseStatus : Boolean; + + Begin + GetBrowseStatus := PBrowser^.StatusOK; + End; + + Function ISBrowser.BuildBrowScreenRow ( Var RR : RowRec ) : Integer; + + Begin + BuildBrowScreenRow := PBrowser^.BuildBrowScreenRow ( RR ); + End; + + + Function ISBrowser.lwAdjustHorizOfs ( Delta : Integer ) : Integer; + + Var + Offset : LongInt; + + Begin + Offset := LongInt (lwHorizOfs) + Delta; + If Offset < 0 Then Begin + Offset := 0; + End Else Begin + If OffSet > lwMaxHorizOfs Then Begin + Offset := lwMaxHorizOfs; + End; + End; + lwAdjustHorizOfs := Offset; + End; + + +{$IFDEF UseScrollBars} + Procedure ISBrowser.lwUpdateVertScrollBar; + {-Update vertical scroll bar} + + Var + RelPos : Word; + Dummy : Integer; + + Begin + With PBrowser^ Do Begin + HGetApprRelPos ( RelPos, lwVertScale, GetCurrentKeyStr, + GetCurrentDatRef ); + If Not StatusOK Then RelPos := 0; + DrawSlider ( frRR, RelPos ); + End; + End; + + Procedure ISBrowser.lwUpdateHorzScrollBar; + {-Update horizontal scroll bar} + + Var + Dummy : Integer; + + Begin + If lwMaxHorizOfs > 0 Then Begin + DrawSlider ( frBB, lwHorizOfs ); + End; + End; +{$ENDIF} + + + Procedure ISBrowser.lwLineDown; + + Var + LRow : Word; + Moved : Word; + CR : Word; + Update, + Dummy : Boolean; + + Begin + Update := True; + With PBrowser^ Do Begin + LRow := GetLastRow; {mod !!.03} + CR := GetCurRow; + If ( CR = LRow ) Or ( LRow = 0 ) Then Begin + HBuildNextPage ( 1, Moved, True, 0, Dummy ); + If StatusOK Then Begin + If OtherAction Then Begin + UpdateContents; + End Else Begin + If Moved = 1 Then Begin + If lwFullPage <> 1 Then Begin + If LRow = GetLastRow Then Begin {mod !!.03} + UpDateContents; + End Else Begin + SetCurRow ( Succ (CR) ); + DisplayRow ( LRow, False); + End; + End; + DisplayRow ( CR, True); + End Else Begin + Update := False; + End; + End; + End Else Begin + Update := False; + End; + End Else Begin + DisplayRow ( CR , False ); + SetCurRow ( Succ (CR) ); + DisplayRow ( GetCurRow, True ); + End; + End; +{$IFDEF UseScrollBars} + If Update Then lwUpdateVertScrollBar; +{$ENDIF} + End; + + + Procedure ISBrowser.lwLineUp; + + Var + Moved : Word; + CR : Word; + Update, + Dummy : Boolean; + + Begin + Update := True; + With PBrowser^Do Begin + CR := GetCurRow; + If CR = 1 Then Begin + HBuildPrevPage ( 1, Moved, True, 0, Dummy ); + If StatusOK Then Begin + If OtherAction Then Begin + UpdateContents; + End Else Begin + If Moved = 1 Then Begin + If lwFullPage <> 1 Then Begin + UpdateContents; + End; + DisplayRow ( 1, True); + End Else Begin + Update := False; + End; + End; + End Else Begin + Update := False; + End; + End Else Begin + DisplayRow ( CR , False ); + SetCurRow ( Pred (CR) ); + DisplayRow ( GetCurRow, True ); + End; + End; +{$IFDEF UseScrollBars} + If Update Then lwUpdateVertScrollBar; +{$ENDIF} + End; + + + Procedure ISBrowser.lwPageDown; + + Var + BST : BrowScreenState; + Moved : Word; + Update, + Changed : Boolean; + + Begin + Update := False; + With PBrowser^ Do Begin + GetBrowScreenState ( BST ); + HBuildNextPage ( lwFullPage, Moved, True, 1, Changed ); + If StatusOK Then Begin + If OtherAction Or (Moved > 0) Or Changed + Or BrowScreenStateChanged ( BST ) Then Begin + UpdateContents; + Update := True; + End; + End; + End; +{$IFDEF UseScrollBars} + If Update Then lwUpdateVertScrollBar; +{$ENDIF} + End; + + + Procedure ISBrowser.lwPageUp; + + Var + BST : BrowScreenState; + Moved : Word; + Update, + Changed : Boolean; + + Begin + Update := False; + With PBrowser^ Do Begin + GetBrowScreenState ( BST ); + HBuildPrevPage ( lwFullPage, Moved, True, 1, Changed ); + If StatusOK Then Begin + If OtherAction Or (Moved > 0) Or Changed + Or BrowScreenStateChanged ( BST ) Then Begin + UpdateContents; + Update := True; + End; + End; + End; +{$IFDEF UseScrollBars} + If Update Then lwUpdateVertScrollBar; +{$ENDIF} + End; + + + Procedure ISBrowser.lwFirstPage; + + Var + BST : BrowScreenState; + Update, + Changed : Boolean; + + Begin + Update := False; + With PBrowser^ Do Begin + GetBrowScreenState ( BST ); + HBuildFirstPage ( Changed ); + If StatusOK Then Begin + If Changed Or BrowScreenStateChanged ( BST ) Then Begin + UpdateContents; + Update := True; + End; + End; + End; +{$IFDEF UseScrollBars} + If Update Then lwUpdateVertScrollBar; +{$ENDIF} + End; + + + Procedure ISBrowser.lwLastPage; + + Var + BST : BrowScreenState; + Update, + Changed : Boolean; + + Begin + Update := False; + With PBrowser^ Do Begin + GetBrowScreenState ( BST ); + HBuildLastPage ( Changed ); + If StatusOK Then Begin + If Changed Or BrowScreenStateChanged ( BST ) Then Begin + UpdateContents; + Update := True; + End; + End; + End; +{$IFDEF UseScrollBars} + If Update Then lwUpdateVertScrollBar; +{$ENDIF} + End; + + + Procedure ISBrowser.lwMoveToRelPos ( Pos : Word ); + + Var + Key : GenKeyStr; + Ref : LongInt; + + Begin + PBrowser^.HGetApprKeyAndRef ( Pos, lwVertScale, Key, Ref ); + SetAndUpdateBrowserScreen ( Key, Ref ); + End; + + + Procedure ISBrowser.lwLineRight; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := lwHorizOfs; + lwHorizOfs := lwAdjustHorizOfs ( 1 ); + If OldHOfs <> lwHorizOfs Then Begin + UpdateContents; +{$IFDEF UseScrollBars} + lwUpdateHorzScrollBar; +{$ENDIF} + End; + End; + + + Procedure ISBrowser.lwLineLeft; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := lwHorizOfs; + lwHorizOfs := lwAdjustHorizOfs ( -1 ); + If OldHOfs <> lwHorizOfs Then Begin + UpdateContents; +{$IFDEF UseScrollBars} + lwUpdateHorzScrollBar; +{$ENDIF} + End; + End; + + + Procedure ISBrowser.lwPageRight; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := lwHorizOfs; + lwHorizOfs := lwAdjustHorizOfs ( 10 ); + If OldHOfs <> lwHorizOfs Then Begin + UpdateContents; +{$IFDEF UseScrollBars} + lwUpdateHorzScrollBar; +{$ENDIF} + End; + End; + + + Procedure ISBrowser.lwPageLeft; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := lwHorizOfs; + lwHorizOfs := lwAdjustHorizOfs ( -10 ); + If OldHOfs <> lwHorizOfs Then Begin + UpdateContents; +{$IFDEF UseScrollBars} + lwUpdateHorzScrollBar; +{$ENDIF} + End; + End; + + + Procedure ISBrowser.lwLeftHome; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := lwHorizOfs; + lwHorizOfs := 0; + If OldHOfs <> lwHorizOfs Then Begin + UpdateContents; +{$IFDEF UseScrollBars} + lwUpdateHorzScrollBar; +{$ENDIF} + End; + End; + + + Procedure ISBrowser.lwRightHome; + + Var + OldHOfs : Integer; + + Begin + If PBrowser = Nil Then Exit; + OldHOfs := lwHorizOfs; + lwHorizOfs := lwMaxHorizOfs; + If OldHOfs <> lwHorizOfs Then Begin + UpdateContents; +{$IFDEF UseScrollBars} + lwUpdateHorzScrollBar; +{$ENDIF} + End; + End; + + + Procedure ISBrowser.lwMoveToHorizPos ( Pos : Word ); + + Var + OldHOfs : Integer; + + Begin + OldHOfs := lwHorizOfs; + lwHorizOfs := Pos; + lwHorizOfs := lwAdjustHorizOfs ( 0 ); + If OldHOfs <> lwHorizOfs Then Begin + UpdateContents; +{$IFDEF UseScrollBars} + lwUpdateHorzScrollBar; +{$ENDIF} + End; + End; + + + +Begin +{--Initialize command processor} + OpBrCommands.Init ( @OpBrKeySet, OPBRKeyMax ); +End. + diff --git a/src/wc_sdk/opdefine.inc b/src/wc_sdk/opdefine.inc new file mode 100644 index 0000000..091c94b --- /dev/null +++ b/src/wc_sdk/opdefine.inc @@ -0,0 +1,152 @@ +{*********************************************************} +{* OPDEFINE.INC 1.30 *} +{* Assorted conditional compilation directives *} +{*********************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{This compiler directive is not needed by OPro itself, but is provided for + other programs and libraries that depend on recognizing the differences + between the OPro 1.20 and later versions, and prior versions. DO NOT + CHANGE THIS DEFINE!!!} + +{$DEFINE OPro12} +{$DEFINE OPro13} + +{This compiler directive controls whether the Float type in OPSTRING is + defined as an Extended or a Real. It also controls the inclusion of certain + methods that apply only to 8087 numeric types.} + + {$N+} + +{This directive forces all units to contain an initialization block, even + those that do not have any actual initialization code. Adding these blocks + helps to work around a bug in Turbo Debugger 1.5.} + + {.$DEFINE InitAllUnits} + +{This directive determines whether or not OPCRT is compiled in such a way as + to coexist peacefully with the standard Turbo Pascal CRT unit.} + + {.$DEFINE UseCrt} + +{This directive enables mouse support in several of the units, as well as in + some of the demo programs} + + {$DEFINE UseMouse} + +{This directive enables scroll bar support in OPWINDOW and units that + depend on it} + + {$DEFINE UseScrollBars} + +{This directive enables hot spot support in OPWINDOW and units that depend + on it} + + {$DEFINE UseHotSpots} + +{This directive enables shadowing support in OPWINDOW} + + {$DEFINE UseShadows} + +{This directive enables the AdjustWindow, ResizeWindow, MoveWindow, and other + methods in OPWINDOW} + + {$DEFINE UseAdjustableWindows} + +{If FourByteDates is defined, dates in OPDATE are stored as longints, giving a +range of 01/01/1600-12/31/3999. If it isn't defined, dates are stored as words, +giving a range of 01/01/1900-12/31/2078.} + + {$DEFINE FourByteDates} + +{The following directive enables support for editing of dates in OPEDIT and +OPENTRY. It also enables certain options in OPDIR.} + + {$DEFINE UseDates} + +{The following directive enables support for BCD reals in OPEDIT and OPENTRY} + + {.$DEFINE UseBCD} + +{The following directive enables support for pick list fields in OPENTRY} + + {$DEFINE PickListFields} + +{Deactivate the following define if the caller of OPSORT needs to perform + heap allocation or deallocation while the sort is in progress, that is, + within the user-defined procedures of the sort. For large sorts with + element size exceeding 4 bytes, FastDispose makes a significant difference + in the speed of heap deallocation when the sort is finished.} + + {$DEFINE FastDispose} + +{If the following directive is defined, OPTSR and OPSWAP try to + thwart SideKick} + + {$DEFINE ThwartSideKick} + +{If the following directive is defined, streams support is enabled in all + objects} + + {$DEFINE UseStreams} + +{If the following directive is defined, XMS support is enabled in OPSWAP. + IMPORTANT: You must also define the SupportXms constant in OPSWAP.ASM and + reassemble the file. Failure to do so will cause an error when recompiling + OPSWAP.} + + {$DEFINE SupportXms} {!!.02} + +{If the following directive is defined, OPDRAG support will be included in all +units containing command windows.} + + {$DEFINE UseDrag} {!!.03} + +{If the following directive is defined, the numeric editor in OPFEDIT will + operate in calculator fashion, allowing the user to enter decimal points + himself.} + + {.$DEFINE UseCalcEdit} {!!.13} + +{The following define controls how various OPRO units react to the heap + changes of TP6. There's no need for you to modify it.} + + {$IFDEF Ver60} + {$DEFINE Heap6} + {$ENDIF} + +{The following define controls how various OPRO units accomodate changes to + the BP7 compiler. These should not be modified.} + + {$IFDEF Ver70} + {$DEFINE Heap6} {use TP6 style heap management in Real mode} + {$I-,P-,T-,X-,Q-} {set specific directives we need} + {$IFDEF Dpmi} {if in protected mode...} + {$UNDEF FastDispose} {no use of FastDispose in sorts} + {$ENDIF} + {$ENDIF} + diff --git a/src/wc_sdk/qxindex.pas b/src/wc_sdk/qxindex.pas new file mode 100644 index 0000000..31f2134 --- /dev/null +++ b/src/wc_sdk/qxindex.pas @@ -0,0 +1,1092 @@ +{********************************************************************} +{* QXINDEX.PAS - Word index for WildCat! file database *} +{* Clean-room replacement for proprietary Mustang Software TPU *} +{* Format: CRC-16 hash-bucketed BST with prefix-compressed keys *} +{* *} +{* File layout: *} +{* Bytes 0..16383: Hash table (4096 x 4-byte LongInt offsets) *} +{* After header: tree nodes and compressed list records *} +{* *} +{* Tree node on disk (17 + suffix bytes): *} +{* left: LongInt (4) - file offset of left child *} +{* right: LongInt (4) - file offset of right child *} +{* listData: LongInt (4) - most recent reference value *} +{* listNext: LongInt (4) - file offset to compressed chain *} +{* prefixdatalen: Byte (1) - high nibble=prefix, low=suffix *} +{* data: array of Byte - suffix key characters *} +{********************************************************************} + +{$X+} +{$I btdefine.inc} + +unit QXIndex; + +interface + +const MaxKeyLength = 15; + +type TIndexKeyString = String[MaxKeyLength]; + + PIndexFile = ^TIndexFile; + TIndexFile = object + f: File; + constructor Init(const fn: String); + destructor Done; virtual; + procedure Add(key: TIndexKeyString; x: Longint); + end; + + PIndexFinder = ^TIndexFinder; + TIndexFinder = object + ifile: PIndexFile; + origkey: TIndexKeyString; + curkey: TIndexKeyString; + extra: record + trail: Pointer; { PIndexTrail linked list } + list: LongInt; { current reference value to return } + last: LongInt; { file offset to compressed chain (0=done) } + atend: Boolean; { iteration finished flag } + end; + constructor Init(aifile: PIndexFile; var akey: TIndexKeyString); + destructor Done; virtual; + function GetNextKey(var akey: TIndexKeyString): Boolean; + function GetNextRef(var n: Longint): Boolean; + end; + +type LockFileProc = function(var f: File): Boolean; + UnlockFileProc = procedure (var f: File); + +var QXLockFile: LockFileProc; + QXUnlockFile: UnlockFileProc; + +implementation + +{======================================================================} +{=== Constants and internal types =====================================} +{======================================================================} + +const + NumBuckets = 4096; + HeaderSize = NumBuckets * SizeOf(Longint); { 16384 bytes } + TreeRecHdrSize = 17; { 4+4+4+4+1 } + +type + TListRecord = packed record + data: LongInt; + next: LongInt; + end; + + { On-disk tree record layout } + TTreeRecordDisk = packed record + left: LongInt; { offset 0 } + right: LongInt; { offset 4 } + listData: LongInt; { offset 8 } + listNext: LongInt; { offset 12 } + prefixdatalen: Byte; { offset 16 } + data: array[0..MaxKeyLength-1] of Byte; { offset 17+ } + end; + + { In-memory trail node layout (key is reconstructed String[15]) } + TTreeRecordMem = packed record + left: LongInt; { offset 0 } + right: LongInt; { offset 4 } + listData: LongInt; { offset 8 } + listNext: LongInt; { offset 12 } + key: TIndexKeyString; { offset 16 } + end; + + TCompressedListRecord = packed record + b: array[0..7] of Byte; + end; + + PIndexTrail = ^TIndexTrail; + TIndexTrail = packed record + prev: PIndexTrail; + flag: Byte; + node: Pointer; { heap copy of TTreeRecordMem } + end; + +{======================================================================} +{=== CRC-CCITT lookup table (verified against original TPU binary) ====} +{======================================================================} + +const CrcTable: array[0..255] of Word = ( + $0000, $1021, $2042, $3063, $4084, $50A5, $60C6, $70E7, + $8108, $9129, $A14A, $B16B, $C18C, $D1AD, $E1CE, $F1EF, + $1231, $0210, $3273, $2252, $52B5, $4294, $72F7, $62D6, + $9339, $8318, $B37B, $A35A, $D3BD, $C39C, $F3FF, $E3DE, + $2462, $3443, $0420, $1401, $64E6, $74C7, $44A4, $5485, + $A56A, $B54B, $8528, $9509, $E5EE, $F5CF, $C5AC, $D58D, + $3653, $2672, $1611, $0630, $76D7, $66F6, $5695, $46B4, + $B75B, $A77A, $9719, $8738, $F7DF, $E7FE, $D79D, $C7BC, + $48C4, $58E5, $6886, $78A7, $0840, $1861, $2802, $3823, + $C9CC, $D9ED, $E98E, $F9AF, $8948, $9969, $A90A, $B92B, + $5AF5, $4AD4, $7AB7, $6A96, $1A71, $0A50, $3A33, $2A12, + $DBFD, $CBDC, $FBBF, $EB9E, $9B79, $8B58, $BB3B, $AB1A, + $6CA6, $7C87, $4CE4, $5CC5, $2C22, $3C03, $0C60, $1C41, + $EDAE, $FD8F, $CDEC, $DDCD, $AD2A, $BD0B, $8D68, $9D49, + $7E97, $6EB6, $5ED5, $4EF4, $3E13, $2E32, $1E51, $0E70, + $FF9F, $EFBE, $DFDD, $CFFC, $BF1B, $AF3A, $9F59, $8F78, + $9188, $81A9, $B1CA, $A1EB, $D10C, $C12D, $F14E, $E16F, + $1080, $00A1, $30C2, $20E3, $5004, $4025, $7046, $6067, + $83B9, $9398, $A3FB, $B3DA, $C33D, $D31C, $E37F, $F35E, + $02B1, $1290, $22F3, $32D2, $4235, $5214, $6277, $7256, + $B5EA, $A5CB, $95A8, $8589, $F56E, $E54F, $D52C, $C50D, + $34E2, $24C3, $14A0, $0481, $7466, $6447, $5424, $4405, + $A7DB, $B7FA, $8799, $97B8, $E75F, $F77E, $C71D, $D73C, + $26D3, $36F2, $0691, $16B0, $6657, $7676, $4615, $5634, + $D94C, $C96D, $F90E, $E92F, $99C8, $89E9, $B98A, $A9AB, + $5844, $4865, $7806, $6827, $18C0, $08E1, $3882, $28A3, + $CB7D, $DB5C, $EB3F, $FB1E, $8BF9, $9BD8, $ABBB, $BB9A, + $4A75, $5A54, $6A37, $7A16, $0AF1, $1AD0, $2AB3, $3A92, + $FD2E, $ED0F, $DD6C, $CD4D, $BDAA, $AD8B, $9DE8, $8DC9, + $7C26, $6C07, $5C64, $4C45, $3CA2, $2C83, $1CE0, $0CC1, + $EF1F, $FF3E, $CF5D, $DF7C, $AF9B, $BFBA, $8FD9, $9FF8, + $6E17, $7E36, $4E55, $5E74, $2E93, $3EB2, $0ED1, $1EF0 +); + +{======================================================================} +{=== Internal helpers =================================================} +{======================================================================} + +{ TrailNodeSize: returns allocation size of a trail node's TTreeRecordMem. + Byte 16 of a TTreeRecordMem is the key length byte; masked with $0F + gives 0..15 which matches the allocation in PushTrail. } +function TrailNodeSize(p: Pointer): Word; +type TBArr = array[0..31] of Byte; +begin + TrailNodeSize := TreeRecHdrSize + (TBArr(p^)[16] and $0F); +end; + +{ MatchBytes: count of leading bytes that match between two strings } +function MatchBytes(const s1, s2: TIndexKeyString): Byte; +var + len, i: Byte; +begin + len := Length(s1); + if Length(s2) < len then + len := Length(s2); + i := 0; + while (i < len) and (s1[i+1] = s2[i+1]) do + Inc(i); + MatchBytes := i; +end; + +{ HashKey: CRC-based hash of first 3 chars, returns 12-bit bucket index } +function HashKey(const key: TIndexKeyString): Word; +var + CRC: Word; + I, N: Byte; +begin + N := Length(key); + if N > 3 then N := 3; + CRC := $FFFF; + for I := 1 to N do + CRC := CrcTable[Hi(CRC)] xor (Word(Lo(CRC)) shl 8) xor Word(Byte(key[I])); + HashKey := CRC and $0FFF; +end; + +{ CompKeys: compare two pascal strings, returns -1/0/+1 } +function CompKeys(const a, b: TIndexKeyString): Integer; +var + MinLen, I: Byte; +begin + MinLen := Length(a); + if Length(b) < MinLen then MinLen := Length(b); + for I := 1 to MinLen do begin + if Byte(a[I]) < Byte(b[I]) then begin CompKeys := -1; Exit; end; + if Byte(a[I]) > Byte(b[I]) then begin CompKeys := 1; Exit; end; + end; + if Length(a) < Length(b) then CompKeys := -1 + else if Length(a) > Length(b) then CompKeys := 1 + else CompKeys := 0; +end; + +{ ReconstructKey: rebuild the full key from parent key + disk node } +function ReconstructKey(const parentKey: TIndexKeyString; + var nr: TTreeRecordDisk): TIndexKeyString; +var + PrefixLen, SuffixLen, I: Byte; + K: TIndexKeyString; +begin + PrefixLen := (nr.prefixdatalen shr 4) and $0F; + SuffixLen := nr.prefixdatalen and $0F; + K[0] := Chr(PrefixLen + SuffixLen); + for I := 1 to PrefixLen do + K[I] := parentKey[I]; + for I := 1 to SuffixLen do + K[PrefixLen + I] := Chr(nr.data[I - 1]); + ReconstructKey := K; +end; + +{ CountBits: number of bits needed to represent val (0 returns 0) } +function CountBits(val: LongInt): Byte; +var + n: Byte; + hi, lo: Word; +begin + if val = 0 then begin + CountBits := 0; + Exit; + end; + hi := Word(val shr 16); + lo := Word(val); + if hi <> 0 then begin + n := $21; + if (hi shr 8) = 0 then begin + Dec(n, 8); + hi := hi shl 8; + end; + Dec(n); + while (hi and $8000) = 0 do begin + Dec(n); + hi := hi shl 1; + end; + end else begin + n := $11; + if (lo shr 8) = 0 then begin + Dec(n, 8); + lo := lo shl 8; + if lo = 0 then begin + CountBits := 0; + Exit; + end; + end; + Dec(n); + while (lo and $8000) = 0 do begin + Dec(n); + lo := lo shl 1; + end; + end; + CountBits := n; +end; + +{======================================================================} +{=== Compressed list record encoding/decoding =========================} +{======================================================================} + +procedure CompressListRecord(var lr: TListRecord; + var cr: TCompressedListRecord); +var + databits, nextbits: Byte; + srcBytes: array[0..4] of Byte; + i: Integer; + bitOfs: Word; + byteOfs: Word; + bitInByte: Byte; + tmpAx, tmpDx: Word; + tmpBh: Byte; + w: Word; +begin + FillChar(cr, 8, 0); + databits := CountBits(lr.data); + nextbits := CountBits(lr.next); + + { Encode data field } + if databits = 0 then + { zero: nothing to store } + else if databits = 1 then + cr.b[0] := 1 + else begin + srcBytes[0] := 0; + srcBytes[1] := Byte(lr.data); + srcBytes[2] := Byte(lr.data shr 8); + srcBytes[3] := Byte(lr.data shr 16); + srcBytes[4] := Byte(lr.data shr 24); + tmpAx := Word(srcBytes[1]) shl 8; + tmpDx := Word(srcBytes[3]) shl 8 or Word(srcBytes[2]); + tmpBh := srcBytes[4]; + for i := 1 to 3 do begin + tmpAx := (tmpAx shr 1) or ((tmpDx and 1) shl 15); + tmpDx := (tmpDx shr 1) or (Word(tmpBh and 1) shl 15); + tmpBh := tmpBh shr 1; + end; + tmpAx := (tmpAx and $FF00) or (Lo(tmpAx) or databits); + cr.b[0] := Lo(tmpAx); + cr.b[1] := Hi(tmpAx); + cr.b[2] := Lo(tmpDx); + cr.b[3] := Hi(tmpDx); + cr.b[4] := tmpBh; + end; + + { Advance bit position past data field } + bitOfs := databits + 4; + byteOfs := bitOfs shr 3; + bitInByte := bitOfs and 7; + + { Encode next field count (5 bits) } + w := Word(cr.b[byteOfs]) or (Word(cr.b[byteOfs + 1]) shl 8); + w := w and Word(not (1 shl bitInByte)); + w := w or (Word(nextbits) shl bitInByte); + cr.b[byteOfs] := Lo(w); + if byteOfs + 1 < 8 then + cr.b[byteOfs + 1] := Hi(w); + + Inc(bitOfs, 5); + if bitInByte + 5 >= 8 then begin + Inc(byteOfs); + bitInByte := (bitInByte + 5) - 8; + end else + Inc(bitInByte, 5); + + { Encode next field value } + if nextbits >= 2 then begin + srcBytes[0] := Byte(lr.next); + srcBytes[1] := Byte(lr.next shr 8); + srcBytes[2] := Byte(lr.next shr 16); + srcBytes[3] := Byte(lr.next shr 24); + srcBytes[4] := 0; + tmpAx := Word(srcBytes[0]) or (Word(srcBytes[1]) shl 8); + tmpDx := Word(srcBytes[2]) or (Word(srcBytes[3]) shl 8); + tmpBh := srcBytes[4]; + for i := 1 to bitInByte do begin + tmpBh := (tmpBh shl 1) or Byte((tmpDx shr 15) and 1); + tmpDx := (tmpDx shl 1) or Word((tmpAx shr 15) and 1); + tmpAx := tmpAx shl 1; + end; + cr.b[byteOfs] := cr.b[byteOfs] or Lo(tmpAx); + if byteOfs + 1 < 8 then + cr.b[byteOfs + 1] := cr.b[byteOfs + 1] or Hi(tmpAx); + if byteOfs + 2 < 8 then + cr.b[byteOfs + 2] := cr.b[byteOfs + 2] or Lo(tmpDx); + if byteOfs + 3 < 8 then + cr.b[byteOfs + 3] := cr.b[byteOfs + 3] or Hi(tmpDx); + if byteOfs + 4 < 8 then + cr.b[byteOfs + 4] := cr.b[byteOfs + 4] or tmpBh; + end; +end; + +procedure DecompressListRecord(var cr: TCompressedListRecord; + var lr: TListRecord); +var + nbits: Byte; + bitOfs: Word; + byteOfs: Word; + bitInByte: Byte; + tmpAx, tmpDx: Word; + tmpBh: Byte; + val: LongInt; + andMsk, orMsk: LongInt; + si: Word; + i: Integer; + w: Word; +begin + lr.data := 0; + lr.next := 0; + + nbits := cr.b[0] and $1F; + if nbits = 0 then + lr.data := 0 + else if nbits = 1 then + lr.data := 1 + else begin + tmpAx := Word(cr.b[0]) or (Word(cr.b[1]) shl 8); + tmpDx := Word(cr.b[2]) or (Word(cr.b[3]) shl 8); + tmpBh := cr.b[4]; + for i := 1 to 5 do begin + tmpAx := (tmpAx shr 1) or ((tmpDx and 1) shl 15); + tmpDx := (tmpDx shr 1) or (Word(tmpBh and 1) shl 15); + tmpBh := tmpBh shr 1; + end; + val := LongInt(tmpAx) or (LongInt(tmpDx) shl 16); + andMsk := (LongInt(1) shl (nbits - 1)) - 1; + orMsk := LongInt(1) shl (nbits - 1); + val := (val and andMsk) or orMsk; + lr.data := val; + end; + + bitOfs := Word(nbits) + 4; + byteOfs := bitOfs shr 3; + bitInByte := bitOfs and 7; + + si := byteOfs; + w := Word(cr.b[si]); + if si + 1 < 8 then + w := w or (Word(cr.b[si + 1]) shl 8); + w := w shr bitInByte; + + Inc(bitOfs, 5); + if bitInByte + 5 >= 8 then begin + Inc(si); + bitInByte := (bitInByte + 5) - 8; + end else + Inc(bitInByte, 5); + + nbits := Lo(w) and $1F; + if nbits = 0 then + lr.next := 0 + else if nbits = 1 then + lr.next := 1 + else begin + tmpAx := Word(cr.b[si]); + if si + 1 < 8 then + tmpAx := tmpAx or (Word(cr.b[si + 1]) shl 8); + if si + 2 < 8 then + tmpDx := Word(cr.b[si + 2]) + else + tmpDx := 0; + if si + 3 < 8 then + tmpDx := tmpDx or (Word(cr.b[si + 3]) shl 8); + if si + 4 < 8 then + tmpBh := cr.b[si + 4] + else + tmpBh := 0; + if bitInByte > 0 then begin + for i := 1 to bitInByte do begin + tmpAx := (tmpAx shr 1) or ((tmpDx and 1) shl 15); + tmpDx := (tmpDx shr 1) or (Word(tmpBh and 1) shl 15); + tmpBh := tmpBh shr 1; + end; + end; + val := LongInt(tmpAx) or (LongInt(tmpDx) shl 16); + andMsk := (LongInt(1) shl (nbits - 1)) - 1; + orMsk := LongInt(1) shl (nbits - 1); + val := (val and andMsk) or orMsk; + lr.next := val; + end; +end; + +{======================================================================} +{=== File I/O helpers =================================================} +{======================================================================} + +function ReadLongAt(var f: File; pos: LongInt): LongInt; +var + val: LongInt; + actual: Word; +begin + val := 0; + Seek(f, pos); + BlockRead(f, val, 4, actual); + ReadLongAt := val; +end; + +procedure WriteLongAt(var f: File; pos: LongInt; val: LongInt); +var + actual: Word; +begin + Seek(f, pos); + BlockWrite(f, val, 4, actual); +end; + +function ReadTreeRecord(var f: File; ofs: LongInt; + var buf: TTreeRecordDisk): Boolean; +var + actual: Word; + datalen: Byte; +begin + ReadTreeRecord := False; + Seek(f, ofs); + BlockRead(f, buf, TreeRecHdrSize, actual); + if actual < TreeRecHdrSize then Exit; + datalen := buf.prefixdatalen and $0F; + if datalen > 0 then begin + BlockRead(f, buf.data, datalen, actual); + if actual < datalen then Exit; + end; + ReadTreeRecord := True; +end; + +procedure ReadCompressedListRec(var f: File; ofs: LongInt; + var cr: TCompressedListRecord); +var + actual: Word; +begin + Seek(f, ofs); + BlockRead(f, cr, 8, actual); +end; + +{======================================================================} +{=== Tree node creation and list management ===========================} +{======================================================================} + +{ CreateTreeNode: append a new tree node to end of file. + Computes prefix compression relative to parentKey. } +function CreateTreeNode(var f: File; + var key, parentKey: TIndexKeyString; + x: LongInt): LongInt; +var + nr: TTreeRecordDisk; + ofs: LongInt; + recsize: Word; + actual: Word; + prefixLen, suffixLen: Byte; + i: Byte; +begin + FillChar(nr, SizeOf(nr), 0); + prefixLen := MatchBytes(key, parentKey); + suffixLen := Length(key) - prefixLen; + nr.left := 0; + nr.right := 0; + nr.listData := x; + nr.listNext := 0; + nr.prefixdatalen := ((prefixLen and $0F) shl 4) or (suffixLen and $0F); + for i := 1 to suffixLen do + nr.data[i - 1] := Byte(key[prefixLen + i]); + ofs := FileSize(f); + recsize := TreeRecHdrSize + suffixLen; + Seek(f, ofs); + BlockWrite(f, nr, recsize, actual); + CreateTreeNode := ofs; +end; + +{ AddListRecord: prepend a new reference to a node's list. + Compresses the old TListRecord and appends it to file, + then writes a new TListRecord(data=x, next=chain_offset) to the node. } +procedure AddListRecord(var f: File; nodeOfs: LongInt; x: LongInt); +var + oldLR: TListRecord; + cr: TCompressedListRecord; + chainOfs: LongInt; + actual: Word; + newLR: TListRecord; +begin + { Read existing raw TListRecord from node at offset 8 } + Seek(f, nodeOfs + 8); + BlockRead(f, oldLR, 8, actual); + { Compress the old TListRecord and append to file } + CompressListRecord(oldLR, cr); + chainOfs := FileSize(f); + Seek(f, chainOfs); + BlockWrite(f, cr, 8, actual); + { Write new raw TListRecord back to node } + newLR.data := x; + newLR.next := chainOfs; + Seek(f, nodeOfs + 8); + BlockWrite(f, newLR, 8, actual); +end; + +{======================================================================} +{=== DoAddToTree: BST insertion with parentKey tracking ===============} +{======================================================================} + +procedure DoAddToTree(var f: File; linkOfs: LongInt; + var key: TIndexKeyString; x: LongInt); +var + nodeOfs: LongInt; + maxOfs: LongInt; + nr: TTreeRecordDisk; + nodeKey: TIndexKeyString; + parentKey: TIndexKeyString; + cmp: Integer; + newNodeOfs: LongInt; + prevLinkOfs: LongInt; +begin + nodeOfs := ReadLongAt(f, linkOfs); + + if nodeOfs = 0 then begin + parentKey := ''; + newNodeOfs := CreateTreeNode(f, key, parentKey, x); + WriteLongAt(f, linkOfs, newNodeOfs); + Exit; + end; + + maxOfs := FileSize(f) - 4; + prevLinkOfs := linkOfs; + parentKey := ''; + + while nodeOfs <> 0 do begin + if (nodeOfs < 0) or (nodeOfs > maxOfs) then Exit; + if not ReadTreeRecord(f, nodeOfs, nr) then Exit; + + { Reconstruct node key using PARENT key, not search key } + nodeKey := ReconstructKey(parentKey, nr); + + cmp := CompKeys(key, nodeKey); + + if cmp = 0 then begin + { Exact match: prepend to list (skip if duplicate) } + if x = nr.listData then Exit; + AddListRecord(f, nodeOfs, x); + Exit; + end; + + if cmp < 0 then begin + prevLinkOfs := nodeOfs; { offset of left field in node } + nodeOfs := nr.left; + end else begin + prevLinkOfs := nodeOfs + 4; { offset of right field in node } + nodeOfs := nr.right; + end; + + if nodeOfs = 0 then begin + { Create new leaf node with nodeKey as parent for prefix } + newNodeOfs := CreateTreeNode(f, key, nodeKey, x); + WriteLongAt(f, prevLinkOfs, newNodeOfs); + Exit; + end; + + { Update parentKey for next iteration } + parentKey := nodeKey; + end; +end; + +{======================================================================} +{=== TIndexFile =======================================================} +{======================================================================} + +constructor TIndexFile.Init(const fn: String); +var + OldFileMode: Byte; + IORes: Integer; + ZeroBuf: array[0..1023] of Byte; + i: Integer; + actual: Word; +begin + Assign(f, fn); + OldFileMode := FileMode; + FileMode := $42; { read/write deny-none } + {$I-} + Reset(f, 1); + {$I+} + FileMode := OldFileMode; + IORes := IOResult; + + if IORes <> 0 then begin + { File doesn't exist - create with zeroed header } + {$I-} + Rewrite(f, 1); + {$I+} + IORes := IOResult; + if IORes <> 0 then Exit; + FillChar(ZeroBuf, SizeOf(ZeroBuf), 0); + for i := 1 to 16 do { 16 x 1024 = 16384 bytes } + BlockWrite(f, ZeroBuf, 1024, actual); + end; +end; + +destructor TIndexFile.Done; +begin + {$I-} + Close(f); + {$I+} + if IOResult <> 0 then ; +end; + +procedure TIndexFile.Add(key: TIndexKeyString; x: Longint); +var + bucketOfs: LongInt; +begin + if Length(key) = 0 then Exit; + if Length(key) > MaxKeyLength then + key[0] := Chr(MaxKeyLength); + + if @QXLockFile <> nil then + if not QXLockFile(f) then Exit; + + bucketOfs := LongInt(HashKey(key)) * 4; + DoAddToTree(f, bucketOfs, key, x); + + if @QXUnlockFile <> nil then + QXUnlockFile(f); +end; + +{======================================================================} +{=== Trail management for TIndexFinder ================================} +{======================================================================} + +procedure NukeTrail(var finder: TIndexFinder); forward; +procedure PushTrail(var finder: TIndexFinder; + var diskNode: TTreeRecordDisk; var fullKey: TIndexKeyString); forward; +procedure PopTrail(var finder: TIndexFinder); forward; +function TopFind(var finder: TIndexFinder; + var akey: TIndexKeyString): Boolean; forward; +function NextTopKey(var finder: TIndexFinder; + var akey: TIndexKeyString): Boolean; forward; +function IncCurKey(var finder: TIndexFinder): Boolean; forward; +function GetNextKeyPrim(var finder: TIndexFinder; + var akey: TIndexKeyString): Boolean; forward; + +procedure NukeTrail(var finder: TIndexFinder); +var + t, prev: PIndexTrail; + nodeSize: Word; +begin + t := PIndexTrail(finder.extra.trail); + while t <> nil do begin + prev := t^.prev; + if t^.node <> nil then begin + nodeSize := TrailNodeSize(t^.node); + FreeMem(t^.node, nodeSize); + end; + FreeMem(t, SizeOf(TIndexTrail)); + t := prev; + end; + finder.extra.trail := nil; +end; + +procedure PushTrail(var finder: TIndexFinder; + var diskNode: TTreeRecordDisk; var fullKey: TIndexKeyString); +var + t: PIndexTrail; + memNode: ^TTreeRecordMem; + nodeSize: Word; +begin + nodeSize := TreeRecHdrSize + Length(fullKey); + GetMem(t, SizeOf(TIndexTrail)); + t^.prev := PIndexTrail(finder.extra.trail); + t^.flag := 0; + GetMem(t^.node, nodeSize); + memNode := t^.node; + memNode^.left := diskNode.left; + memNode^.right := diskNode.right; + memNode^.listData := diskNode.listData; + memNode^.listNext := diskNode.listNext; + memNode^.key := fullKey; + finder.extra.trail := t; +end; + +procedure PopTrail(var finder: TIndexFinder); +var + t: PIndexTrail; + nodeSize: Word; +begin + t := PIndexTrail(finder.extra.trail); + if t = nil then Exit; + finder.extra.trail := t^.prev; + if t^.node <> nil then begin + nodeSize := TrailNodeSize(t^.node); + FreeMem(t^.node, nodeSize); + end; + FreeMem(t, SizeOf(TIndexTrail)); +end; + +function TrailNodeRight(t: PIndexTrail): LongInt; +var pn: ^TTreeRecordMem; +begin + pn := t^.node; + TrailNodeRight := pn^.right; +end; + +function TrailNodeLeft(t: PIndexTrail): LongInt; +var pn: ^TTreeRecordMem; +begin + pn := t^.node; + TrailNodeLeft := pn^.left; +end; + +function TrailNodeListData(t: PIndexTrail): LongInt; +var pn: ^TTreeRecordMem; +begin + pn := t^.node; + TrailNodeListData := pn^.listData; +end; + +function TrailNodeListNext(t: PIndexTrail): LongInt; +var pn: ^TTreeRecordMem; +begin + pn := t^.node; + TrailNodeListNext := pn^.listNext; +end; + +function TrailNodeKey(t: PIndexTrail): TIndexKeyString; +var pn: ^TTreeRecordMem; +begin + pn := t^.node; + TrailNodeKey := pn^.key; +end; + +{ SetFinderFromNode: copy the raw TListRecord from a tree node to + the finder's Extra.List and Extra.Last fields. } +procedure SetFinderFromNode(var finder: TIndexFinder; + listData, listNext: LongInt); +begin + finder.extra.list := listData; + finder.extra.last := listNext; + finder.extra.atend := (listData = 0) and (listNext = 0); +end; + +{======================================================================} +{=== TopFind: find first matching key in bucket (with parentKey fix) ==} +{======================================================================} + +function TopFind(var finder: TIndexFinder; + var akey: TIndexKeyString): Boolean; +var + bucketOfs: LongInt; + nodeOfs: LongInt; + nr: TTreeRecordDisk; + nodeKey: TIndexKeyString; + parentKey: TIndexKeyString; + mb: Byte; + cmp: Integer; +begin + TopFind := False; + if finder.extra.atend then Exit; + + bucketOfs := LongInt(HashKey(finder.curkey)) * 4; + nodeOfs := ReadLongAt(finder.ifile^.f, bucketOfs); + parentKey := ''; + + while nodeOfs <> 0 do begin + if not ReadTreeRecord(finder.ifile^.f, nodeOfs, nr) then begin + finder.extra.atend := True; + Exit; + end; + + { Reconstruct node key using PARENT key, not search key } + nodeKey := ReconstructKey(parentKey, nr); + + mb := MatchBytes(finder.origkey, nodeKey); + cmp := CompKeys(finder.origkey, nodeKey); + + PushTrail(finder, nr, nodeKey); + + if (cmp = 0) or (mb >= Length(finder.origkey)) then begin + finder.curkey := nodeKey; + SetFinderFromNode(finder, nr.listData, nr.listNext); + akey := nodeKey; + TopFind := True; + Exit; + end; + + { Update parentKey before descending } + parentKey := nodeKey; + + if cmp < 0 then + nodeOfs := nr.left + else + nodeOfs := nr.right; + end; + + finder.extra.atend := True; +end; + +{======================================================================} +{=== NextTopKey: find next matching key via trail backtracking ========} +{======================================================================} + +function NextTopKey(var finder: TIndexFinder; + var akey: TIndexKeyString): Boolean; +var + t: PIndexTrail; + nodeOfs: LongInt; + nr: TTreeRecordDisk; + nodeKey: TIndexKeyString; + parentKey: TIndexKeyString; + mb: Byte; +begin + NextTopKey := False; + + while finder.extra.trail <> nil do begin + t := PIndexTrail(finder.extra.trail); + + if t^.flag = 0 then begin + t^.flag := 1; + { The trail node is the parent of any right subtree nodes } + parentKey := TrailNodeKey(t); + nodeOfs := TrailNodeRight(t); + + while nodeOfs <> 0 do begin + if not ReadTreeRecord(finder.ifile^.f, nodeOfs, nr) then + Break; + + { Reconstruct using parentKey, not search key } + nodeKey := ReconstructKey(parentKey, nr); + + mb := MatchBytes(finder.origkey, nodeKey); + + if mb >= Length(finder.origkey) then begin + PushTrail(finder, nr, nodeKey); + finder.curkey := nodeKey; + SetFinderFromNode(finder, nr.listData, nr.listNext); + akey := nodeKey; + NextTopKey := True; + Exit; + end; + + { Update parentKey as we descend } + parentKey := nodeKey; + + if CompKeys(finder.origkey, nodeKey) < 0 then + nodeOfs := nr.left + else + nodeOfs := nr.right; + end; + end; + + PopTrail(finder); + end; + + finder.extra.atend := True; +end; + +{======================================================================} +{=== IncCurKey: increment search key for cross-bucket iteration =======} +{======================================================================} + +function IncCurKey(var finder: TIndexFinder): Boolean; +var + len: Byte; +begin + IncCurKey := False; + + { Only cross buckets for keys shorter than 3 chars } + if Length(finder.origkey) >= 3 then + Exit; + + len := Length(finder.curkey); + if len = 0 then Exit; + + while len > 0 do begin + if Byte(finder.curkey[len]) < 255 then begin + finder.curkey[len] := Chr(Byte(finder.curkey[len]) + 1); + finder.curkey[0] := Chr(len); + if len >= Length(finder.origkey) then begin + if Copy(finder.curkey, 1, Length(finder.origkey)) = finder.origkey then begin + IncCurKey := True; + Exit; + end; + end; + Exit; + end; + Dec(len); + end; +end; + +{======================================================================} +{=== GetNextKeyPrim: combines NextTopKey + IncCurKey ==================} +{======================================================================} + +function GetNextKeyPrim(var finder: TIndexFinder; + var akey: TIndexKeyString): Boolean; +begin + GetNextKeyPrim := False; + if finder.extra.atend then Exit; + + if NextTopKey(finder, akey) then begin + GetNextKeyPrim := True; + Exit; + end; + + if IncCurKey(finder) then begin + NukeTrail(finder); + if TopFind(finder, akey) then begin + GetNextKeyPrim := True; + Exit; + end; + end; + + finder.extra.atend := True; +end; + +{======================================================================} +{=== TIndexFinder =====================================================} +{======================================================================} + +constructor TIndexFinder.Init(aifile: PIndexFile; var akey: TIndexKeyString); +var + dummy: TIndexKeyString; + Locked: Boolean; +begin + ifile := aifile; + origkey := akey; + curkey := akey; + extra.trail := nil; + extra.list := 0; + extra.last := 0; + extra.atend := False; + + if (ifile = nil) or (Length(akey) = 0) then begin + extra.atend := True; + ifile := nil; + Fail; + Exit; + end; + + Locked := False; + if @QXLockFile <> nil then begin + Locked := QXLockFile(aifile^.f); + if not Locked then begin + extra.atend := True; + ifile := nil; + Fail; + Exit; + end; + end; + + if not TopFind(Self, dummy) then begin + if not NextTopKey(Self, dummy) then + extra.atend := True; + end; + + if extra.atend then begin + { No match found - clean up and fail } + NukeTrail(Self); + if Locked and (@QXUnlockFile <> nil) then + QXUnlockFile(aifile^.f); + ifile := nil; + Fail; + end; +end; + +destructor TIndexFinder.Done; +begin + NukeTrail(Self); + if (ifile <> nil) and (@QXUnlockFile <> nil) then + QXUnlockFile(ifile^.f); +end; + +{======================================================================} +{=== TIndexFinder.GetNextKey ==========================================} +{======================================================================} + +function TIndexFinder.GetNextKey(var akey: TIndexKeyString): Boolean; +var + dummy: TIndexKeyString; +begin + GetNextKey := False; + if extra.atend then Exit; + + akey := curkey; + GetNextKey := True; + + if not GetNextKeyPrim(Self, dummy) then + extra.atend := True; +end; + +{======================================================================} +{=== TIndexFinder.GetNextRef ==========================================} +{======================================================================} + +function TIndexFinder.GetNextRef(var n: Longint): Boolean; +var + cr: TCompressedListRecord; + lr: TListRecord; + dummy: TIndexKeyString; +begin + GetNextRef := False; + if extra.atend then Exit; + + { Return the current reference value } + if extra.list <> 0 then begin + n := extra.list; + extra.list := 0; { consumed } + GetNextRef := True; + { If no chain, advance to next key } + if extra.last = 0 then begin + if not GetNextKeyPrim(Self, dummy) then + extra.atend := True; + end; + Exit; + end; + + { Follow compressed chain } + if extra.last = 0 then Exit; + + ReadCompressedListRec(ifile^.f, extra.last, cr); + DecompressListRecord(cr, lr); + + n := lr.data; + extra.last := lr.next; + GetNextRef := True; + + if lr.next = 0 then begin + if not GetNextKeyPrim(Self, dummy) then + extra.atend := True; + end; +end; + +begin + QXLockFile := nil; + QXUnlockFile := nil; +end. diff --git a/src/wc_sdk/qxstub.pas b/src/wc_sdk/qxstub.pas new file mode 100755 index 0000000..b259ead --- /dev/null +++ b/src/wc_sdk/qxstub.pas @@ -0,0 +1,59 @@ +unit QXStub; +{$I btdefine.inc} + +interface + +implementation + +uses Dos, Crt, Filer, QXIndex, BTISBase; + +procedure WriteTopRight(const s: String); + +var x, y: Word; + +begin + x := WhereX; + y := WhereY; + GotoXY(65, 1); + Write(s); + GotoXY(x, y); +end; + +function LockFile(var f: File): Boolean; far; + +var retries: Word; + covers: Pointer; + s: String[5]; + +begin + LockFile := False; + covers := nil; + retries := 0; + while not BTIsamLockRecord(0, 1, FileRec(f).Handle, 768, 64) do begin + IsamDelay(Random(200)); + Inc(retries); + if retries > 50 then + Exit; + Str(retries, s); + WriteTopRight('Lock retry #'+s); + end; + if retries > 0 then + WriteTopRight(' '); + LockFile := True; +end; + +procedure UnlockFile(var f: File); far; + +begin + BTIsamUnLockRecord(0, 1, FileRec(f).Handle); +end; + +begin +{$IFDEF FPC} + QXLockFile := LockFileProc(@LockFile); + QXUnlockFile := UnlockFileProc(@UnlockFile); +{$ELSE} + QXLockFile := LockFile; + QXUnlockFile := UnlockFile; +{$ENDIF} +end. diff --git a/src/wc_sdk/rebuild.pas b/src/wc_sdk/rebuild.pas new file mode 100644 index 0000000..e86b23b --- /dev/null +++ b/src/wc_sdk/rebuild.pas @@ -0,0 +1,83 @@ +{********************************************************************} +{* REBUILD.PAS - rebuild fileblock *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + +Unit + Rebuild; + +Interface + +Uses + BTBase, + BTIsBase, + Filer, {!!.TP} + Restruct, + Reindex; + + Procedure RebuildFileBlock ( FBlName : IsamFileBlockName; + DatSLen : LongInt; + NumberOfKeys : Word; + IID : IsamIndDescr; + BuildKeyFunc : FuncBuildKey ); + {-Rebuilds a fixed record length fileblocks data and index structure} + + +Implementation + + Procedure RebuildFileBlock ( FBlName : IsamFileBlockName; + DatSLen : LongInt; + NumberOfKeys : Word; + IID : IsamIndDescr; + BuildKeyFunc : FuncBuildKey ); + + Var + Dummy : Boolean; + + Begin + RestructFileBlock ( FBlName, DatSLen, DatSLen, False, 0, + ChangeDatSNoChange, BTNoCharConvert, Nil ); + If Not IsamOK Then Exit; + If NumberOfKeys > 0 Then Begin + ReIndexFileBlock ( FBlName, NumberOfKeys, IID, False, + BuildKeyFunc, True, Dummy, + BTNoCharConvert, Nil ); + End; + End; + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/reindex.pas b/src/wc_sdk/reindex.pas new file mode 100644 index 0000000..729b085 --- /dev/null +++ b/src/wc_sdk/reindex.pas @@ -0,0 +1,553 @@ +{********************************************************************} +{* REINDEX.PAS - reindex fileblock *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + +Unit ReIndex; {!!.50} + +Interface + +Uses + BTBase, + BTIsBase, + Filer, {!!.TP} + VRec, {!!.TP} + BufRecIO; + +Type + FuncBuildKey = Function ( Var DatS; + KeyNr : Word ) : IsamKeyStr; + + + Procedure ReIndexFileBlock ( FBlName : IsamFileBlockName; + NumberOfKeys : Word; + IID : IsamIndDescr; + VarRec : Boolean; + BuildKeyFunc : FuncBuildKey; + DelRecDupKey : Boolean; + Var MsgFileCreated : Boolean; + CharConvProc : ProcBTCharConvert; + CCHookPtr : Pointer ); + + {-Reindexes a fileblock with variable or fixed record lengths by + creating a new index file} + + +Implementation + +{$IFDEF Win32} {!!.54} +uses {!!.54} + Windows; {!!.54} +{$ENDIF} {!!.54} + +{$UNDEF NeedAssigned} +{$IFDEF VER60} +{$DEFINE NeedAssigned} +{$ENDIF} +{$IFDEF VER15} +{$DEFINE NeedAssigned} +{$ENDIF} + +{$IFDEF NeedAssigned} +function Assigned(var P) : boolean; + var + Pt : pointer absolute P; + begin + Assigned := Pt <> nil; + end; +{$ENDIF} + + Type + IsamSmallInfoRec = packed Record + Gener : Array [1..5] Of LongInt; + ADK : Boolean; + End; + + Procedure ReIndexFileBlock ( FBlName : IsamFileBlockName; + NumberOfKeys : Word; + IID : IsamIndDescr; + VarRec : Boolean; + BuildKeyFunc : FuncBuildKey; + DelRecDupKey : Boolean; + Var MsgFileCreated : Boolean; + CharConvProc : ProcBTCharConvert; + CCHookPtr : Pointer ); + + Var + FNameTemp, + FNameD, + FNameI : IsamFileBlockName; + IFBPtr : IsamFileBlockPtr; + BufPtr : Pointer; + BufLen : Word; + MsgFile : Text; + DataRecLen : LongInt; + IORes : Integer; + + + Procedure CheckDatF ( Var DatSLen : LongInt ); + + Var + F : IsamFile; + Header : IsamSmallInfoRec; + DosSize : DWORD; {!!.54} + NumRec : LongInt; + FFree : LongInt; + + + Procedure UnDo ( Err : Integer ); + + Begin + IsamClose ( F ); + IsamOK := Err <> 0; + IsamError := Err; + End; + + + Begin + DatSLen := 0; + IsamAssign ( F, IsamForceExtension ( FNameD, DatExtension ) ); + IsamReset ( F, False, False ); + If Not IsamOK Then Exit; + + IsamLongSeekEOF ( F, DosSize ); + If Not IsamOK Then Begin + UnDo ( IsamError ); + Exit; + End; + + IsamGetBlock ( F, 0, SizeOf (Header), Header ); + If Not IsamOK Then Begin + UnDo ( IsamError ); + Exit; + End; + + If Header.Gener [4] {LenRec} = 0 Then Begin + UnDo ( 10215 ); + Exit; + End; + + NumRec := DosSize Div Header.Gener [4] {LenRec}; + If NumRec * Header.Gener [4] {LenRec} <> DosSize Then Begin + UnDo ( 10215 ); + Exit; + End; + DatSLen := Header.Gener [4] {LenRec}; + + If Pred (NumRec) <> Header.Gener [3] {NumRec} Then Begin + UnDo ( 10215 ); + Exit; + End; + + If Header.Gener [1] {FirstFree} <> -1 Then Begin + If Header.Gener [1] {FirstFree} > 0 Then Begin + IsamGetBlock ( F, Header.Gener [1] {FirstFree}, + SizeOf (FFree), FFree ); + If Not IsamOK Then Begin + UnDo ( IsamError ); + Exit; + End; + End Else Begin + FFree := 0; + End; + If FFree = 0 Then Begin + UnDo ( 10215 ); + Exit; + End; + End; + + DatSLen := Header.Gener [4] {LenRec}; + IsamClose ( F ); + End; + + + Procedure CreateNewIndexFile; + + Var + F : IsamFile; + SaveExt : String [3]; + + Begin + SaveExt := DatExtension; + DatExtension := MsgExtension; + + {--Create a fileblock with a data file name equal to message file name; + so we do not (!) overwrite the data file} + BTCreateFileBlock ( FNameD + ';' + FNameI, DataRecLen, NumberOfKeys, + IID ); + + DatExtension := SaveExt; + If Not IsamOK Then Exit; + + IsamAssign ( F, IsamForceExtension ( FNameD, MsgExtension ) ); + IsamDelete ( F ); + End; + + + Procedure SetNewHeader; + + Var + F : IsamFile; + Header : IsamSmallInfoRec; + + + Procedure UnDo ( Err : Integer ); + + Begin + IsamClose ( F ); + IsamOK := Err <> 0; + IsamError := Err; + End; + + + Begin + {--Open the data file to read the headerd} + IsamAssign ( F, IsamForceExtension ( FNameD, DatExtension ) ); + IsamReset ( F, False, False ); + If Not IsamOK Then Exit; + + IsamGetBlock ( F, 0, SizeOf (Header), Header ); + If Not IsamOK Then Begin + UnDo ( IsamError ); + Exit; + End; + + {--Set the (potentially different) number of keys in the header} + Header.Gener [5] := NumberOfKeys; + + {--Clear the data buffered flag} + Header.ADK := False; + + {--Write the header back to the data file and close it} + IsamPutBlock ( F, 0, SizeOf (Header), Header ); + If Not IsamOK Then Begin + UnDo ( IsamError ); + Exit; + End; + IsamClose ( F ); + End; + + + Procedure UnDo ( Level : Word; Error : Integer ); + + Begin + If BufPtr <> Nil Then Begin + FreeMem ( BufPtr, BufLen ); + End; + + If MsgFileCreated Then Close ( MsgFile ); + + If Level >= 2 Then Begin + DoneRecBuffers; + End; + + If Level >= 1 Then Begin + BTCloseFileBlock ( IFBPtr ); + End; + + IsamOK := False; + IsamError := Error; + End; + + + Function AdjustBuffer ( ToSize : Word ) : Boolean; + {-Called only when variable recs are used} + + + Function Alloc ( Var P : Pointer; Size : Word ) : Boolean; + {!!.52 rewritten} + Begin + Alloc := False; + while not IsamGetMem(P, Size) do + if not DecreaseBufferMem then + Exit; + Alloc := True; + End; + + + Begin + AdjustBuffer := False; + + If BufPtr <> Nil Then Begin + FreeMem ( BufPtr, BufLen ); + BufPtr := Nil; + End; + + If Not Alloc ( BufPtr, ToSize ) Then Exit; + BufLen := ToSize; + + AdjustBuffer := True; + End; + + + Procedure DumpToMessageFile ( Nr : Word; + Ref : LongInt; + IKS : IsamKeyStr ); + + Var + PC : ^Char; + W : Word; + + Begin + If Not MsgFileCreated Then Begin + Assign ( MsgFile, IsamForceExtension ( FNameD, MsgExtension ) ); + Rewrite ( MsgFile ); + IORes := IOResult; + If IORes <> 0 Then Exit; + MsgFileCreated := True; + End; + + Writeln ( MsgFile, 'Key:<', IKS, '>', ' KeyNr: ', Nr, ' Ref: ', Ref, + ' not added' ); + IORes := IOResult; + If IORes <> 0 Then Exit; + + If DelRecDupKey Then Begin + WriteLn ( MsgFile, 'Data record deleted - Dump follows'); + PC := @BufPtr^; + For W := 1 To DataRecLen Do Begin + Write ( MsgFile, PC^); + Inc (LongInt (PC)); + End; + Writeln ( MsgFile, ^M^J); + IORes := IOResult; + End; + End; + + + Var + I, J, + MaxSize, + CurRecLen : Word; + Stop, + RetryRead, + WasRead : Boolean; + CurrentRef, + DatSRead, + DatSWritten : LongInt; + IKS : IsamKeyStr; + + Begin + IsamClearOK; + + {--Set buffer pointers to Nil and reference return value to no} + BufPtr := Nil; + MsgFileCreated := False; + + {--Get file names for data and index file} + IsamExtractFileNames ( FBlName, FNameD, FNameTemp ); + IsamExtractFileNames ( FNameTemp, FNameI, FNameTemp {dummy} ); + + {--Check data file and return record length} + CheckDatF ( DataRecLen ); + If Not IsamOK Then Exit; + + {--Check record lengths} + If VarRec Then Begin + MaxSize := MaxVariableRecLength; + End Else Begin + MaxSize := $FFFF; + End; + If DataRecLen > MaxSize Then Begin + UnDo ( 0, 10412 ); + Exit; + End; + + {--Adjust buffer for variable recs} + If VarRec Then Begin + If Not BTAdjustVariableRecBuffer ( DataRecLen ) Then Begin + UnDo ( 0, 10411 ); + Exit; + End; + End; + + {--Create a new and empty index file} + CreateNewIndexFile; + If Not IsamOK Then Begin + UnDo ( 0, IsamError ); + Exit; + End; + + {--Modify the header of the data file} + SetNewHeader; + If Not IsamOK Then Begin + UnDo ( 0, IsamError ); + Exit; + End; + + {--The fileblock is now prepared to be opened; so open the fileblock} + BTOpenFileBlock ( IFBPtr, FNameD + ';' + FNameI, False, False, False, + False ); + If Not IsamOK Then Begin + UnDo ( 0, IsamError ); + Exit; + End; + + {--Get buffer for data read (no write)} + CreateRecBuffers ( DataRecLen, Nil ); + + {--Get buffer for a single record} + If Not AdjustBuffer ( DataRecLen ) Then Begin + UnDo ( 2, 10411 ); + Exit; + End; + + {--Reindexing loop} + For I := 1 To NumberOfKeys Do Begin + RewindReadBuffer; + + {--Initialize status and control data} + CurRecLen := DataRecLen; + CurrentRef := 0; + DatSRead := 0; + DatSWritten := 0; + Stop := False; + + Repeat + {--Read record} + If VarRec Then Begin + Repeat + RetryRead := False; + BufGetVariableRecRebuilt ( IFBPtr^.DatF, DataRecLen, CurrentRef, + BufPtr, BufLen, WasRead, CurRecLen ); + If Not IsamOK Then Begin + If (IsamError = 10415) Or (IsamError = 10070) Then Begin + {-A fractal record was read, skip it and retry} + IsamClearOK; + RetryRead := True; + End Else Begin + {-A serious error occured} + UnDo ( 2, IsamError ); + Exit; + End; + End Else Begin + If Not WasRead Then Begin + If CurRecLen = 0 Then Begin + {-No more data} + Stop := True; + End Else Begin + {-Buffer was too small} + If AdjustBuffer ( CurRecLen ) Then Begin + {-Buffer adjusted, so try it again} + RetryRead := True; + End Else Begin + {-No more memory for buffer} + UnDo ( 2, 10411 ); + Exit; + End; + End; + End; + End; + Until Not RetryRead; + End Else Begin + Repeat + Inc (CurrentRef); + BufGetBlock ( IFBPtr^.DatF, CurrentRef * DataRecLen, DataRecLen, + BufPtr^ ); + If Not IsamOk Then Begin + If IsamError = 10070 Then Begin + IsamClearOK; + Stop := True; + End Else Begin + UnDo ( 4, IsamError ); + Exit; + End; + End; + Until Stop Or (LongInt (BufPtr^) = 0); + End; + + If Not Stop Then Begin + Inc (DatSRead); + CharConvProc ( BufPtr, CurRecLen, True, CCHookPtr ); + IKS := BuildKeyFunc ( BufPtr^, I ); + If Not IsamOK Then Begin + UnDo ( 2, 10470 ); + Exit; + End; + If AddNullKeys Or (IKS <> '') Then Begin + BTAddKey ( IFBPtr, I, CurrentRef, IKS ); + If Not IsamOK Then Begin + If IsamError = 10230 Then Begin + DumpToMessageFile ( I, CurrentRef, IKS ); + IsamClearOK; + If IORes <> 0 Then Begin + UnDo ( 2, 9500 + IORes ); + Exit; + End; + If DelRecDupKey Then Begin + For J := 1 To Pred (I) Do Begin + BTDeleteKey ( IFBPtr, J, CurrentRef, + BuildKeyFunc ( BufPtr^, J ) ); + End; + If VarRec Then Begin + BTDeleteVariableRec ( IFBPtr, CurrentRef ); + End Else Begin + BTDeleteRec ( IFBPtr, CurrentRef ); + End; + MarkReadBufRecDeleted ( CurrentRef ); + End; + End Else Begin + UnDo ( 2, IsamError ); + Exit; + End; + End Else Begin + Inc (DatSWritten); + End; + End; + If Assigned(IsamReXUserProcPtr) Then Begin + IsamReXUserProcPtr(I, DatSRead, DatSWritten, BufPtr^, CurRecLen ); + If Not IsamOK Then Begin + UnDo ( 2, 10460 ); + Exit; + End; + End; + End; + Until Stop; + End; + + FreeMem ( BufPtr, BufLen ); + DoneRecBuffers; + {-Cannot result in an error} + If MsgFileCreated Then Close ( MsgFile ); + I := IOResult; + {-Not really an error, if it may not be clossed correctly} + BTCloseFileBlock ( IFBPtr ); + End; + + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. \ No newline at end of file diff --git a/src/wc_sdk/reorg.pas b/src/wc_sdk/reorg.pas new file mode 100644 index 0000000..323e806 --- /dev/null +++ b/src/wc_sdk/reorg.pas @@ -0,0 +1,87 @@ +{********************************************************************} +{* REORG.PAS - reorganize fileblock *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + +Unit + ReOrg; + +Interface + +Uses + BTBase, + BTIsBase, + Filer, {!!.TP} + Restruct, + Reindex; + + Procedure ReorgFileBlock ( FBlName : IsamFileBlockName; + DatSLen : LongInt; + NumberOfKeys : Word; + IID : IsamIndDescr; + DatSLenOld : LongInt; + BuildKeyFunc : FuncBuildKey; + ChangeDatSProc : FuncChangeDatS); + {-Reorganizes a fixed record length fileblocks data and index structure} + + +Implementation + + Procedure ReorgFileBlock ( FBlName : IsamFileBlockName; + DatSLen : LongInt; + NumberOfKeys : Word; + IID : IsamIndDescr; + DatSLenOld : LongInt; + BuildKeyFunc : FuncBuildKey; + ChangeDatSProc : FuncChangeDatS); + + Var + Dummy : Boolean; + + Begin + RestructFileBlock ( FBlName, DatSLen, DatSLenOld, False, 0, + ChangeDatSProc, BTNoCharConvert, Nil ); + If Not IsamOK Then Exit; + If NumberOfKeys > 0 Then Begin + ReIndexFileBlock ( FBlName, NumberOfKeys, IID, False, + BuildKeyFunc, True, Dummy, + BTNoCharConvert, Nil ); + End; + End; + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/restruct.pas b/src/wc_sdk/restruct.pas new file mode 100644 index 0000000..bdf9a99 --- /dev/null +++ b/src/wc_sdk/restruct.pas @@ -0,0 +1,495 @@ +{********************************************************************} +{* RESTRUCT.PAS - restructure fileblock *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + +Unit ReStruct; {!!.50} + +Interface + +Uses + BTBase, + BTIsBase, + Filer, {!!.TP} + VRec, {!!.TP} + BufRecIO; + +Type + FuncChangeDatS = Function ( Var DatSOld; + Var DatSNew; + Var Len : Word ) : Boolean; + + + Procedure RestructFileBlock ( FBlName : IsamFileBlockName; + DatSLen : LongInt; + DatSLenOld : LongInt; + VarRec : Boolean; + MaxDiffBytes : LongInt; + ChangeDatSFunc : FuncChangeDatS; + CharConvProc : ProcBTCharConvert; + CCHookPtr : Pointer ); + {-Restructures a fileblock's data file with variable or fixed + record lengths; deletes the old index file} + + Function ChangeDatSNoChange ( Var DatSOld; + Var DatSNew; + Var Len : Word ) : Boolean; + {-Simply copies DatSOld to DatSNew; returns true, if not deleted} + + +Implementation + +{$UNDEF NeedAssigned} +{$IFDEF VER60} +{$DEFINE NeedAssigned} +{$ENDIF} +{$IFDEF VER15} +{$DEFINE NeedAssigned} +{$ENDIF} + +{$IFDEF NeedAssigned} +function Assigned(var P) : boolean; + var + Pt : pointer absolute P; + begin + Assigned := Pt <> nil; + end; +{$ENDIF} + + Procedure RestructFileBlock ( FBlName : IsamFileBlockName; + DatSLen : LongInt; + DatSLenOld : LongInt; + VarRec : Boolean; + MaxDiffBytes : LongInt; + ChangeDatSFunc : FuncChangeDatS; + CharConvProc : ProcBTCharConvert; + CCHookPtr : Pointer ); + + + Var + FNameTemp, + FNameD, + FNameI, + FNameS : IsamFileBlockName; + IFBPtr : IsamFileBlockPtr; + BufPtrOld, + BufPtrNew : Pointer; + BufLenOld, + BufLenNew : Word; + F : IsamFile; + SavFileExisted, + ExtraSaveDirUsed : Boolean; + + + Procedure CreateSaveFile; + + Var + F : IsamFile; + + Begin + IsamAssign ( F, IsamForceExtension ( FNameD, DatExtension ) ); + IsamRename ( F, IsamForceExtension ( FNameS, SavExtension ) ); + If Not IsamOK Then Begin + If IsamError = 10140 Then Begin + IsamError := 10399; + Exit; + End; + If IsamExists ( IsamForceExtension ( FNameS, SavExtension ) ) + Then Begin + IsamClearOK; + SavFileExisted := True; + End Else Begin + If Not ExtraSaveDirUsed Then Begin + IsamOK := False; + IsamError := 10410; + Exit; + End; + IsamClearOK; + IsamAssign ( F, IsamForceExtension ( FNameI, IxExtension ) ); + IsamDelete ( F ); + IsamClearOK; + IsamCopyFile ( IsamForceExtension ( FNameD, DatExtension ), + IsamForceExtension ( FNameS, SavExtension ), True ); + End; + End; + End; + + + Procedure RecreateDataFile; + + Var + F : IsamFile; + + Begin + If SavFileExisted Then Exit; + IsamClearOK; + IsamAssign ( F, IsamForceExtension ( FNameS, SavExtension ) ); + IsamRename ( F, IsamForceExtension ( FNameD, DatExtension ) ); + If Not IsamOK Then Begin + IsamClearOK; + IsamCopyFile ( IsamForceExtension ( FNameS, SavExtension ), + IsamForceExtension ( FNameD, DatExtension ), True ); + End; + End; + + + Procedure UnDo ( Level : Word; Error : Integer ); + + Begin + If BufPtrOld <> Nil Then Begin + FreeMem ( BufPtrOld, BufLenOld ); + End; + + If BufPtrNew <> Nil Then Begin + FreeMem ( BufPtrNew, BufLenNew ); + End; + + If Level >= 4 Then Begin + IsamClose ( F ); + End; + + If Level >= 3 Then Begin + DoneRecBuffers; + End; + + If Level >= 2 Then Begin + BTCloseFileBlock ( IFBPtr ); + End; + + If Level >= 1 Then Begin + BTDeleteFileBlock ( FblName ); + RecreateDataFile; + End; + + IsamOK := False; + IsamError := Error; + End; + + + Function AdjustBuffers ( ToSize1, ToSize2 : Word ) : Boolean; + {-Called only when variable recs are used} + + + Function Alloc ( Var P : Pointer; Size : Word ) : Boolean; + {!!.52 rewritten} + Begin + Alloc := False; + while not IsamGetMem(P, Size) do + if not DecreaseBufferMem then + Exit; + Alloc := True; + End; + + + Begin + AdjustBuffers := False; + + If BufPtrOld <> Nil Then Begin + FreeMem ( BufPtrOld, BufLenOld ); + BufPtrOld := Nil; + End; + If BufLenNew <> ToSize2 Then Begin + If BufPtrNew <> Nil Then Begin + FreeMem ( BufPtrNew, BufLenNew ); + BufPtrNew := Nil; + End; + End; + + If Not Alloc ( BufPtrOld, ToSize1 ) Then Exit; + BufLenOld := ToSize1; + + If BufPtrNew = Nil Then Begin + If Not Alloc ( BufPtrNew, ToSize2 ) Then Begin + FreeMem ( BufPtrOld, BufLenOld ); + BufPtrOld := Nil; + Exit; + End; + BufLenNew := ToSize2; + End; + + AdjustBuffers := True; + End; + + + Type + PIsamIndDescr = ^IsamIndDescr; + + Var + MaxSize, + CurRecLen, + OldRecLen, + InitBufSize, + TempSize : Word; + Ok, + Stop, + RetryRead, + WasRead : Boolean; + CurrentRef, + DatSRead, + DatSWritten : LongInt; + + Begin + IsamClearOK; + SavFileExisted := False; + + {--Set buffer pointers to Nil} + BufPtrOld := Nil; + BufPtrNew := Nil; + BufLenOld := 0; + BufLenNew := 0; + + {--Get file names for data, index, and save file} + IsamExtractFileNames ( FBlName, FNameD, FNameTemp ); + IsamExtractFileNames ( FNameTemp, FNameI, FNameS ); + ExtraSaveDirUsed := FNameS <> FNameTemp; + If Not ExtraSaveDirUsed Then Begin + FNameS := FNameD; + End; + + {--Check record lengths} + If VarRec Then Begin + MaxSize := MaxVariableRecLength; + End Else Begin + MaxSize := $FFFF; + End; + If (DatSLenOld > MaxSize) Or (DatSLen > MaxSize) Then Begin + UnDo ( 0, 10412 ); + Exit; + End; + + {--Do data and save file exist simultaniously?} + If IsamExists ( IsamForceExtension ( FNameS, SavExtension ) ) And + IsamExists ( IsamForceExtension ( FNameD, DatExtension ) ) + Then Begin + UnDo ( 0, 10465 ); + Exit; + End; + + {--Adjust buffer for variable recs} + If VarRec Then Begin + If DatSLenOld > DatSLen Then Begin + InitBufSize := DatSLenOld; + End Else Begin + InitBufSize := DatSLen; + End; + If Not BTAdjustVariableRecBuffer ( InitBufSize ) Then Begin + UnDo ( 0, 10411 ); + Exit; + End; + End Else Begin + MaxDiffBytes := 0; + End; + + {--Move data to save file} + CreateSaveFile; + If Not IsamOK Then Begin + UnDo ( 0, IsamError ); + Exit; + End; + + {--Create the new fileblock without keys} + BTCreateFileBlock ( FNameD + ';' + FNameI, DatSLen, 0, + PIsamIndDescr (@MaxSize)^ {dummy} ); + If Not IsamOK Then Begin + UnDo ( 0, IsamError ); + Exit; + End; + + {--Open the new fileblock} + BTOpenFileBlock ( IFBPtr, FNameD + ';' + FNameI, False, False, False, + False ); + If Not IsamOK Then Begin + UnDo ( 1, IsamError ); + Exit; + End; + + {--Get buffer for data read and write} + CreateRecBuffers ( DatSLenOld, IFBPtr ); + + {--Get buffers for records} + If VarRec Then Begin + If MaxDiffBytes < 0 Then Begin + InitBufSize := - MaxDiffBytes; + End Else Begin + InitBufSize := DatSLenOld + MaxDiffBytes; + End; + End Else Begin + InitBufSize := DatSLen; + End; + If Not AdjustBuffers ( DatSLenOld, InitBufSize ) Then Begin + UnDo ( 3, 10411 ); + Exit; + End; + + {--Open save file for reading} + IsamAssign ( F, IsamForceExtension ( FNameS, SavExtension ) ); + IsamReset ( F, False, False ); + If Not IsamOK Then Begin + UnDo ( 3, IsamError ); + Exit; + End; + + {--Initialize status and control data} + CurRecLen := 0; + CurrentRef := 0; + DatSRead := 0; + DatSWritten := 0; + Stop := False; + + {--Restructure loop} + Repeat + {--Read record} + If VarRec Then Begin + Repeat + RetryRead := False; + BufGetVariableRecRebuilt ( F, DatSLenOld, CurrentRef, BufPtrOld, + BufLenOld, WasRead, CurRecLen ); + If Not IsamOK Then Begin + If (IsamError = 10415) Or (IsamError = 10070) Then Begin + {-A fractal record was read, skip it and retry} + IsamClearOK; + RetryRead := True; + End Else Begin + {-A serious error occured} + UnDo ( 4, IsamError ); + Exit; + End; + End Else Begin + If Not WasRead Then Begin + If CurRecLen = 0 Then Begin + {-No more data} + Stop := True; + End Else Begin + {-Buffer was too small} + If MaxDiffBytes < 0 Then Begin + TempSize := - MaxDiffBytes; + End Else Begin + TempSize := CurRecLen + MaxDiffBytes; + End; + If AdjustBuffers ( CurRecLen, TempSize ) Then Begin + {-Buffer adjusted, so try it again} + RetryRead := True; + End Else Begin + {-No more memory for buffer} + UnDo ( 4, 10411 ); + Exit; + End; + End; + End; + End; + Until Not RetryRead; + End Else Begin + Inc (CurrentRef); + BufGetBlock ( F, CurrentRef * DatSLenOld, DatSLenOld, BufPtrOld^ ); + If Not IsamOk Then Begin + If IsamError = 10070 Then Begin + IsamClearOK; + Stop := True; + End Else Begin + UnDo ( 4, IsamError ); + Exit; + End; + End; + CurRecLen := DatSLenOld; + End; + + If Not Stop Then Begin + Inc (DatSRead); + CharConvProc ( BufPtrOld, CurRecLen, True, CCHookPtr ); + OldRecLen := CurRecLen; + Ok := ChangeDatSFunc ( BufPtrOld^, BufPtrNew^, CurRecLen ); + If Not VarRec Then CurRecLen := DatSLen; + {-Reset in case CurRecLen was changed} + If Not IsamOK Then Begin + UnDo ( 4, 10475 ); + Exit; + End; + If Ok Then Begin + CharConvProc ( BufPtrNew, CurRecLen, False, CCHookPtr ); + If VarRec Then Begin + BufAddVariableRecRebuilt ( IFBPtr, BufPtrNew, CurRecLen ); + End Else Begin + BufAddRec ( IFBPtr, BufPtrNew^ ); + End; + If Not IsamOK Then Begin + UnDo ( 4, IsamError ); + Exit; + End; + Inc (DatSWritten); + End; + + If Assigned(IsamReXUserProcPtr) Then Begin + IsamReXUserProcPtr(0, DatSRead, DatSWritten, + BufPtrOld^, OldRecLen ); + If Not IsamOK Then Begin + UnDo ( 4, 10460 ); + Exit; + End; + End; + End; + Until Stop; + + FreeMem ( BufPtrOld, BufLenOld ); + FreeMem ( BufPtrNew, BufLenNew ); + DoneRecBuffers; + Ok := IsamOK; + BTCloseFileBlock ( IFBPtr ); + Ok := Ok And IsamOK; + IsamClearOK; + IsamClose ( F ); + If IsamOK And Ok Then Begin + IsamDelete ( F ); + End; + End; + + + Function ChangeDatSNoChange ( Var DatSOld; + Var DatSNew; + Var Len : Word ) : Boolean; + + Begin + If LongInt (DatSOld) = 0 Then Begin + Move ( DatSOld, DatSNew, Len ); + ChangeDatSNoChange := True; + End Else Begin + ChangeDatSNoChange := False; + End; + End; + + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/sample.pas b/src/wc_sdk/sample.pas new file mode 100755 index 0000000..3cace4f --- /dev/null +++ b/src/wc_sdk/sample.pas @@ -0,0 +1,509 @@ +program Sample; + +(* + + This is a sample program that demonstrates the usage of the sample database + code provided for developers with Wildcat 4.0. The main unit upon which + the sample database code is built upon is the WcDb unit. This unit contains + an object that encapsulates a IsamFileBlockPtr that the main database + routines in Btree Filer utilize. + + +***** TFileBlock ***** + + Here is a list of routines in TFileBlock object contained in WcDb and + their instructions + + procedure Lock; + {-Locks the fileblock of the current database. This routine can be + called multiple times and it will increment a lock count. Unlock + must be called the same number of times to unlock the database} + + procedure Unlock; + {-Unlocks the fileblock of the database} + + function BuildKey(const Data; Key : Integer) : IsamKeyStr; virtual; + {-Builds a database key based on the record passed into the Data + parameter and the Key that is specified. This routine is overriden + in each of the database units to returns the proper type of key for + each database} + + {The following routines work exactly like their counterparts in Filer + (BtGetRec, BtAddRec, BtPutRec) except you don't have to pass in the + FileBlockPtr because it is part of the object. In the TVFileBlock + object these routines are overriden to call the appropriate Filer + routines from the VRec unit} + procedure GetRec(RefNr : LongInt; var Data); virtual; + procedure AddRec(var RefNr : LongInt; var Data); virtual; + procedure PutRec(RefNr : LongInt; var Data); virtual; + + + {The following routines work exactly like their counterparts in + Filer (BtDeleteRec, BtAddKey, BtDeleteKey, BtDeleteAllKeys, BtRecLen, + BtFileLen, BtFreeRecs, BtUsedRecs, BtUsedKeys, BtClearKey, BtNextDiffKey, + BtPrevDiffKey, BtSearchKey, BtKeyExists) except that you don't have to + pass in the IsamFileBlockPtr parameter that the Filer versions require} + procedure DelRec(RefNr : LongInt); virtual; + procedure AddKey(KeyNr : Integer; RefNr : LongInt; Key : IsamKeyStr); + procedure DeleteKey(KeyNr : Integer; RefNr : LongInt; Key : IsamKeyStr); + procedure DeleteAllKeys(KeyNr : Integer); + function RecLen : Word; + function FileLen : LongInt; + function FreeRecs : LongInt; + function UsedRecs : LongInt; + function UsedKeys(KeyNr : Integer) : LongInt; + procedure ClearKey(KeyNr : Integer); + procedure NextDiffKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr); + procedure PrevDiffKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr); + procedure SearchKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr); + function KeyExists(KeyNr : Integer; RefNr : LongInt; Key : IsamKeyStr) : Boolean; + + + {The following routines work exactly like their counterparts in + Filer (BtFindKey, BtNextKey, BtPrevKey) except that you don't have to + pass the IsamFileBlockPtr to them like the Filer routines. Also these + routines all return a parameter indicating the success of the operation} + function FindKey(KeyNr : Integer; var RefNr : LongInt; Key : IsamKeyStr) : Boolean; + function NextKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr) : Boolean; + function PrevKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr) : Boolean; + + {The following routines are high level routines for adding, deleting, and + updating records in the database. Each of these routines will automatically + add or delete keys for the record in the database. You should use these + routines for adding, deleting, or updating records in the database + rather then the lower level versions above} + + function AddRecord(var RefNr : LongInt; var Data) : Boolean; virtual; + {-Adds a new record to the database and the keys for the record. RefNr + returns the reference to the new record is added. Data is record to be + added} + procedure UpdateRecord(var OldData, NewData); + {-Update a record in the database, automatically deletes the old + keys and adds new keys if necessary. OldData is the old record, + NewData is the new record} + procedure UpdateRecordKey(const Key : IsamKeyStr; var NewData); + {-Does a search on the primary key for the database and updates the + record that the key points to with the new record contained in + NewData. Automatically updates any keys} + function DeleteRecord(var Data) : Boolean; + {-Delete the record Data that is passed in and removes any keys + associated with that record} + function DeleteRecordKey(const Key : IsamKeyStr) : Boolean; + {-Does a search on the primary key of the database and deletes the + record that uses the Key that is passed in} + + {The following routines are used internally by the database object + and it's various decendents. You should not have to call these + routines when using the object} + + procedure FatalDBError(const S : String); virtual; + procedure LogDBError(const S : String); virtual; + procedure GetCreateInfo(var Len : Word; var Keys : Integer; var IID : IsamIndDescr); virtual; + procedure PostCreate; virtual; + function LockOkay : Boolean; + procedure PutRecordPrim(RefNr : LongInt; var OldData, NewData); virtual; + procedure DeleteRecordPrim(RefNr : LongInt; var Data); virtual; + +(*************************** TVFileBlock ***************************** + + Here is a list of routines from the TVFileBlock object. The TVFileBlock + object is a object that encapulates a Filer IsamFileBlockPtr that is + being used to access a database that contains variable sized records using + the VRec unit that comes with Btree Filer: + + function DataLen(const Data) : Word; virtual; + {-Returns the len of the variable sized record that is passed in the + Data parameter} + procedure GetRec(RefNr : LongInt; var Data); virtual; + {-Overrides the TFileBlock.GetRec and makes the proper call to load a + variable sized record} + procedure AddRec(var RefNr : LongInt; var Data); virtual; + {-Overrides the TFileBlock.AddRec and makes the proper call to load a + variable sized record} + procedure PutRec(RefNr : LongInt; var Data); virtual; + {-Overrides the TFileBlock.PutRec and makes the proper call to load a + variable sized record} + procedure DelRec(RefNr : LongInt); virtual; + {-Overrides the TFileBlock.DelRec and makes the proper call to load a + variable sized record} + procedure GetRecPart(RefNr : LongInt; var Data; Len : Word); + {-Exactly the same as the BtGetVariableRecPart routine that is in the VRec + unit except that you don't have to pass the IsamFileBlockPtr paramter} + + {the following routines allow you to get, add, delete, and update fixed + sized records in a VRec database} + procedure GetFixedRec(RefNr : LongInt; var Data); + procedure AddFixedRec(var RefNr : LongInt; var Data); + procedure DelFixedRec(RefNr : LongInt); + procedure PutFixedRec(RefNr : LongInt; var Data); + +(*************************** TFileDb ***************************** + + The TFileDb object is used in accessing the file database. It is + derived from the TVFileBlock and the TFileBlock objects. This means + that you can call any routines that are in those objects from this + object. + + The only methods in this object override methods from the other + two objects. You should add, delete, and update records in the + file database calling the high level database routines in the TFileBlock. + + Here is an example of using the file database object: + + var + RefNr : LongInt; + Key : IsamKeyStr; + + + if FileDb.Init(MwConfig.FileDataBasePath+'ALLFILES') then + + +(*************************** TUserDb ***************************** + + The TUserDb object is used in accessing the user database. It is + derived from the TFileBlock objects This means that you can call any + routines that are in TFileBlock from this object. + + The only methods in this object override methods from the other + two objects. You should add, delete, and update records in the + user database calling the high level database routines in the TFileBlock. + + The user database only offers access to the fixed portion of a user record. + Wildcat also keeps a secondary database to store the data that Wildcat + stores on a conference by conference basis. In order to access this + information on a user you need to use the TUserWrapper object which hides + all of the messy stuff for getting access to the conference data. In order + to construct a TUserWrapper you must first have a TUserRec filled with + User information from the user database. + + To load a user record you might do something like this: + + var + RefNr : LongInt; + UserRec : TUserRec; + LastRead : Word; + + if not UserDb.Init then begin + WriteLn('Unable to open the user database'); + Exit; + end; + if UserDb.FindKey(UserRealKey, RefNr, 'SCOTT HUNTER') then begin + UserDb.GetRec(RefNr, UserRec); + + At this point we have a user record loaded and now we will create a + UserWrapper to access the conference data such as the users last message + read in a conference. + + UserConfPtr = New(TUserWrapper, Init(@UserRec)); + if UserConfPtr = nil then begin + {out of memory, display error message} + Exit; + end; + + LastRead := UserConfPtr^.GetLastRead(4); {this gets the users last read + message from conference 4} + + Then when we are done with accessing the user record we free the pointer + to the TUserWrapper: + + Dispose(UserConfPtr, Done); + + Note: You only have to do the work of allocating a UserWrapper if you need + access to the conference members of a user record. For just accessing a + TUserRec you don't need any of the following steps. + + + constructor Init(var UserRec : TUserRec); + {-This is used to initial a TUserWrapper for use, pass in the UserRec + parameter the user whom you wish to do operations on} + destructor Done; virtual; + {-Call this when you no longer need your user wrapper} + procedure SetDirty; + {-The user wrapper caches data in pages in order to be fast, however + sometimes you need to force a reload of the data from disk to see + if changed} + function GetFlags(Conf : Word) : Byte; + {-Returns the conference flags for a user in Conf conference. See the + cuf* flags in WCTYPE.PAS for these flags} + function FlagIsSet(Mask : Byte; Conf : Word) : Boolean; + {-Returns a boolean indicating if the flags passed in Mask are set in Conf + for the user} + function NextSet(Mask : Byte; Current : Word) : Word; + {-Will return the next conference after Current that the flags set in + Mask are set. If none are found the routine will return NoMoreBits} + function PrevSet(Mask : Byte; Current : Word) : Word; + {-Will return the previous conference before Current that the flags set in + Mask are set. If none are found the routine will return NoMoreBits} + function FirstSet(Mask : Byte) : Word; + {-Returns the first conference the user has the flags set in Mask set. + If none are found the routine will return NoMoreBits} + function LastSet(Mask : Byte) : Word; + {-Returns the first conference the user has the flags set in Mask set. + If none are found the routine will return NoMoreBits} + function FlagsSet(Mask : Byte) : Word; + {-Returns a count of how many conference the flags past in Mask are set + for the user} + procedure SetAllFlags(Mask : Byte); + {-Sets the flags specified in Mask for all conferences} + procedure ClearAllFlags(Mask : Byte); + {-Clears the flags specified in Mask for all conferences} + procedure ToggleFlag(Mask : Byte; Conf : Word); + {-Toggles the flags specified in Mask for all conferences} + function GetLastRead(Conf : Word) : Word; + {-Returns the user last message read pointer for Conf conference} + function GetFirstUnread(Conf : Word) : Word; + {-Returns the first unread message # to the user in conference Conf} + procedure SetFlags(Conf : Word; NewFlags : Byte); + {-Sets the flags in NewFlags for the user in conference Conf} + procedure SetLastRead(Conf, NewLastRead : Word); + {-Sets the users last read pointer in conference Conf to NewLastRead} + procedure SetFirstUnread(Conf, NewFirstUnread: Word); + {-Sets the users first unread pointer in conference Conf to NewFirstUnread} + procedure SetFlags_LastRead(Conf : Word; NewFlags : Byte; NewLastRead : Word); + {-Set the users flags to NewFlags and last message read to NewLastRead + in conference Conf} + + {The following routines are used internally by the user wrapper and + should not be called directly by your code} + function GetConfPage(Conf : Word) : Integer; + procedure LoadConfPage(Conf : Word; ForceLoad : Boolean); + procedure SaveConfPage; + +*) + +(*************************** TMsgDb ***************************** + + The TMsgDb object is a special object in that with Wildcat 4.0 for the + first time we are not using Btree Filer for the message sub-system. We + now use a flat file message system that allows for much faster adding + of messages to the database. This object still behaves very much like + a Filer object. You can check IsamOk to check for errors just like you + would in the other objects. To use the object you call the contructor + with the conference you wish to access and then call the various members. + + Here is a short example of opening a conference and reading message + number 100 from conference 0. + + var + RefNr : LongInt; + MsgHdr : TMsgHeader; + + + if not MsgDb.Init(0) then begin + WriteLn('Unable to open the message database'); + Exit; + end; + RefNr := FindMsg(100); + if IsamOk then begin + GetMsgHeaderAndText(RefNr, MsgHdr, 0, SizeOf(Buffer)); + if not IsamOk then + WriteLn('Error loading message'); + end else + WriteLn('Unable to find message 100'); + + + constructor Init(AConf : Word); + {-Initialize a message database object for the given conference number} + destructor Done; virtual; + {-Shut down a conference object, must be called to close files} + procedure Lock; + {-Lock the database, used internally by AddMsg and MarkMsgRead} + procedure Unlock; + {-Unlock the database} + function AddMsg(var ref: Longint; var msg: TMsgHeader; msgtext: PMsgText) : Boolean; + {-Add a message to the database given a message header (msg) and text (msgtext). + Returns the new reference number in ref} + function FindMsg(msgnum: Word): Longint; + {-Given a message number, this returns the reference number at which + it was found} + function SearchMsg(msgnum: Word): Longint; + {-Given a message number, this returns the reference number of the + message that has the same or a higher message number (if the + requested message number doesn't exist} + procedure NextMsg(var ref: Longint); + {-This will increment a reference number to point to the next message} + procedure PrevMsg(var ref: Longint); + {-This will decrement a reference number to point to the previous message} + procedure GetMsgStatus(var msr: TMsgStatus); + {-This will return the lowest, highest, and number of active (not + deleted) messages in the database} + procedure GetMsgHeader(ref: Longint; var msg: TMsgHeader); + {-This will get the message header for a given reference number} + procedure GetMsgHeaderAndText(ref: Longint; var msg: TMsgHeader; buffer: PMsgText; offset, len: Word); + {-Reads the message header and the text for a given reference number. + The offset and len parameters tell the procedure + +*) + +uses + Dos, + Crt, + WcType, + WcGlobal, + WcFileDb, + WcUserDb, + WcMsgDb, + WcMisc, + Filer; + + + function InitFiler : Boolean; + begin + BtInitIsam(NetSupportType(MwConfig^.Network), MinimizeUseOfNormalHeap, 0); + InitFiler := IsamOk; + end; + + + function LoadMakeWild(var MwConfig : TMakewildRec) : Boolean; + var + F : File of TMakewildRec; + SaveFileMode : Word; + + begin + LoadMakewild := False; + Assign(F, 'MAKEWILD.DAT'); + SaveFileMode := FileMode; + FileMode := ShareMode; + Reset(F); + FileMode := SaveFileMode; + if IoResult <> 0 then + Exit; + Read(F, MwConfig); + LoadMakewild := IoResult = 0; + Close(F); + if IoResult = 0 then + {ignore}; + end; + + + function Register : Boolean; + begin + Register := False; + if not LoadMakeWild(MwConfig^) then + Exit; + if not InitFiler then + Exit; + OpenFile(NodeInfoFile, MwConfig^.NodeInfoPath+'NODEINFO.DAT', SizeOf(TMasterInfo)); + Register := True; + end; + + + procedure UnRegister; + begin + CloseFile(NodeInfoFile); + end; + +var + HighPtr : Word; + RefNr : LongInt; + KeyStr : IsamKeyStr; + UserRec : TUserRec; + + + procedure CheckConference(const Name : String; Conf, FirstUnread : Word); + var + Count : Word; + RefNr : LongInt; + MsgHdr : TMsgHeader; + + begin + if MsgDb.Open(Conf, False) then + begin + Count := 0; + RefNr := MsgDb.FindMsg(FirstUnread); + if not IsamOk then + WriteLn('Unable to find first message'); + while IsamOk do + begin + Inc(Count); + MsgDB.GetMsgHeader(RefNr, MsgHdr); + with MsgHdr do + if FlagIsSet(mFlags, mfReceived) then + WriteLn('Msg ', MsgNumber:5, ' is marked as received, prev link = ', + PrevUnread:5, ' next link = ', NextUnread:5) + else + WriteLn('Msg ', MsgNumber:5, ' is unread , prev link = ', + PrevUnread:5, ' next link = ', NextUnread:5); + if MsgHdr.NextUnread > MsgHdr.MsgNumber then + begin + RefNr := MsgDb.FindMsg(MsgHdr.NextUnread); + if not IsamOk then + WriteLn('Error find next message in chain'); + end + else + IsamOk := False; + end; + if Count = 0 then + WriteLn('No messages found, firstunread is wrong'); + MsgDb.Done; + end + else + WriteLn('Unable to access conference ', Conf); + end; + +var + Len, + I : Byte; + Name : String[25]; + Io, + FirstUnread : Word; + F : File; + Found : Boolean; + + +begin + if not Register then + begin + WriteLn('Unable to initialize.'); + Exit; + end; + + {user database sample} + if not UserDb.Init then + begin + WriteLn('Unable to open the user database.'); + Exit; + end; + + I := 1; + while I <= ParamCount do + begin + Name := Name + ' ' + Trim(ParamStr(I)); + Inc(I); + end; + + if Length(Name) = 0 then + Name := 'Paul Davis'; + + Name := Trim(Name); + WriteLn(Name); + Found := False; + + MsgDb.Init; {Initialize MsgDB object} + + if UserDb.FindKey(UserRealKey, RefNr, StUpcase(Name)) then + begin + UserDb.GetRec(RefNr, UserRec); + if IsamOk then + begin + UserConfPtr := New(PUserWrapper, Init(UserRec)); + for I := 0 to MwConfig^.MaxConfAreas - 1 do + begin + FirstUnread := UserConfPtr^.GetFirstUnread(I); + if FirstUnread > 0 then + begin + WriteLn('Mail in ', I); + CheckConference(Name, I, FirstUnread); + Found := True; + end; + end; + if not Found then + WriteLn('User has no mail waiting'); + Dispose(UserConfPtr, Done); + end; + end + else + WriteLn('Unable to find ', Name); + + UnRegister; +end. diff --git a/src/wc_sdk/search.pas b/src/wc_sdk/search.pas new file mode 100755 index 0000000..0344eb3 --- /dev/null +++ b/src/wc_sdk/search.pas @@ -0,0 +1,131 @@ +program SEARCH; + +uses + WcGlobal, + WcType, + WcFileDB, + WcMisc, + Filer, + QxIndex, + QxStub; + +(* + + +This is an example of how to use the file indexer with the ALLFILES.QX file, +you must first init the TINDEXFILE object found in QXINDEX.INT, this is done +in the WCFILEDB object, all you need to pass to it is the name of the index +file, the index routines will create one if the file is not found. + +To use the search capabilities you need to init an TINDEXFINDER object found +again in QXINDEX.INT, you pass it the pointer to the TINDEXFILE that is +already initialized and it will return false if it did not initialize +succesfully or did not find any matches, from there you can use the GETNEXTKEY +or GETNEXTREF functions to go through the files that it has found. + +Anytime you are using the QXINDEX file YOU MUST include the QXSTUB unit in +your uses statement because it initializes two functions that the indexer +uses, if you do not do this then the program will crash and burn. + + +*) + +var + MatchStr : String; + KeyStr : String[15]; + FileInfo : TFileRec; + Finder : TIndexFinder; + FileRef : LongInt; + + function InitFiler : Boolean; + begin + BtInitIsam(NetSupportType(MwConfig^.Network), MinimizeUseOfNormalHeap, 0); + InitFiler := IsamOk; + end; + + + function LoadMakeWild(var MwConfig : TMakewildRec) : Boolean; + var + F : File of TMakewildRec; + SaveFileMode : Word; + + begin + LoadMakewild := False; + Assign(F, 'MAKEWILD.DAT'); + SaveFileMode := FileMode; + FileMode := ShareMode; + Reset(F); + FileMode := SaveFileMode; + if IoResult <> 0 then + Exit; + Read(F, MwConfig); + LoadMakewild := IoResult = 0; + Close(F); + if IoResult = 0 then + {ignore}; + end; + + + function Register : Boolean; + begin + Register := False; + if not LoadMakeWild(MwConfig^) then + Exit; + if not InitFiler then + Exit; + OpenFile(NodeInfoFile, MwConfig^.NodeInfoPath+'NODEINFO.DAT', SizeOf(TMasterInfo)); + Register := True; + end; + + + procedure UnRegister; + begin + CloseFile(NodeInfoFile); + end; + + +begin + if not Register then + begin + WriteLn('Unable to register'); + Exit; + end; + + + if not FileDB.Init(MwConfig^.FileDataBasePath+'ALLFILES') then + begin + WriteLn('Could not init FILEDB'); + Exit; + end; + + + repeat + WriteLn; + Write('Enter text to search for (enter to abort): '); + ReadLn(MatchStr); + if MatchStr <> '' then + begin + if Length(MatchStr) > 15 then + WriteLn('Match string is too long (15 characters or less') + else if Length(MatchStr) = 1 then + WriteLn('Match string is too short (2 characters or more') + else + begin + KeyStr := StUpCase(MatchStr); + if not Finder.Init(@FileDB.IndexDB, KeyStr) then + WriteLn('Could not find any files matching '+MatchStr) + else + begin + while Finder.GetNextRef(FileRef) do + begin + FileDB.GetRec(FileRef, FileInfo); + WriteLn('Found File '+FileInfo.FileName); + end; + Finder.Done; + end; + end; + end; + until MatchStr = ''; + + UnRegister; +end. \ No newline at end of file diff --git a/src/wc_sdk/share.pas b/src/wc_sdk/share.pas new file mode 100644 index 0000000..1719af8 --- /dev/null +++ b/src/wc_sdk/share.pas @@ -0,0 +1,930 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$F-,V-,B-,S-,I-,R-,X+} {!!.51} + {$IFDEF CanAllowOverlays} + {$F+,O+,A-} + {$ENDIF} + {$IFDEF CanSetOvrflowCheck} + {$Q-,P-} + {$ENDIF} + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +unit Share; + {-DOS 3.x+ network related routines} + +interface + +uses + {$IFDEF Windows} + WinProcs, + WinTypes, + {$IFDEF Ver80} + SysUtils, + DosSupp, + {$ELSE} + WinDos, + {$ENDIF} + DPMI; + {$ELSE} + {$IFNDEF FPC} + {$IFDEF DPMI} + WinAPI, + DPMI, + {$ENDIF} + {$ENDIF} + Dos; + {$ENDIF} + +const + shErrShareNotLoaded = $FFFF; {SHARE.EXE or equivalent not loaded} + shErrFileNotOpen = $FFFE; {File variable is not open} + shErrBadDosVersion = $FFFD; {Call not supported under version of DOS} + shErrNoDosMemory = $FFFC; {No DOS memory available for call} + +type + DeviceType = (DevInvalid, {enum type for redirectable devices} + DevPrinter, + DevDrive); + PrnSetupStr = string[64]; {type for printer setup strings} + PCLanOpType = (LanUnknown, {enum type for PC LAN operating modes} + LanRedirector, + LanReceiver, + LanMessenger, + LanServer); + + LocalStr = string[15]; {string type for local (NetBIOS) names} + NetworkStr = string[127]; {string type for network names} + +var + DosMajor, DosMinor : byte; {the workstation's DOS version} + +function CancelRedirection(LocalName : LocalStr) : word; + {-Cancel a redirection previously set with RedirectDevice} + +function DosLockRec(var F; FilePosition, FileLength : longint) : word; + {-Lock region of file + Notes: this function uses the DOS function to lock a region of a + file. The function result is 0 if successful, the DOS error code, + or one of the shErrXxxx error codes.} + +function GetExtendedError(var EClass, Action, Locus : byte) : word; + {-Return extended information about the last DOS error + Notes: this function must be called *immediately* a DOS error + occurs and before another DOS function is called.} + +function GetMachineName(var MachineName : LocalStr; + var MachineNum : byte) : word; + {-Return the workstation's machine name and NetBIOS name index} + +function GetPrinterSetup(var SetupStr : PrnSetupStr; RDLIndex : word) : word; + {-Return the printer setup string for the specified device in the + redirection table} + +function GetRedirectionEntry(RDLIndex : Word; + var LocalName : LocalStr; + var NetworkName: NetworkStr; + var Parameter : word; + var Dev : DeviceType) : word; + {-Return information about the specified redirection entry} + +function GetTempFileName(PathName : string; + var TempFileName : string) : word; + {-Return a file name guaranteed to be unique in the specified + directory. + Notes: the file will be created and closed by this function. You + must use the returned name to open the file. You are responsible + for deleting the file if required - it is not automatically + erased.} + +function IBMPCLanLoaded(var Lan : PCLanOpType) : boolean; + {-Return true and the LAN type if the IBM PC LAN program is loaded. + Notes: other network programs may also pass this test, eg NetWare + will if the INT2F TSR has been loaded.} + +function IsDriveLocal(Drive : byte) : boolean; + {-Return true if the specified drive number is local to the current + workstation. + Notes: the drive number id one of: 0 = default, 1 = A:, 2 = B:, + and so on. If any errors occur then the function returns true.} + +function IsFileLocal(var F) : Boolean; + {-Return true if the specified file is local to the current + workstation. + Notes: If any errors occur then the function returns true.} + +function RedirectDevice(TypeOfDev : DeviceType; + LocalName : LocalStr; + NetworkName: NetworkStr; + Password : NetworkStr; + Parameter : word) : word; + {-Associate a local name with a network printer or disk. + Notes: LocalName is the name of a local device (eg LPT1, LPT2, + etc) or drive (eg 'F:', 'G:', etc). NetworkName specifies the name + of the network resource LocalName will refer to (the syntax for + specifying directories may vary from network to network). Password + may be required by a network to gain access to a network resource. + Parameter is a user-specified word value that will be returned by + GetRedirectionEntry. The function result is 0 is successful, or + the DOS error code if not.} + +function SetPrinterSetup(SetupStr : PrnSetupStr; + RDLIndex : word) : word; + {-Define a printer setup string for the specified device in the + redirection table} + +function ShareInstalled : boolean; + {-Return true if the SHARE.EXE file-sharing engine is installed. + Notes: this function always returns true under Windows 3.1, so + to really check you must try and lock a region of a file.} + +function UnlockDosRec(var F; FilePosition, FileLength : longint) : word; + {-Unlock region of file + Notes: this function uses the DOS function to unlock a region of a + file. The positiona dnlength parameters must match exactly a + previous call to DosLockRec. You must unlock all file regions + explicitly at the end of the program. The function result is 0 if + successful, the DOS error code, or one of the shErrXxxx error + codes.} + +function UpdateFile(var F) : word; + {-Flushes an open file to disk. + Notes: the function result is 0 if successful, or the DOS error + code, or one of the shErrXxxx error codes.} + +implementation + +type + LH = record L, H : word; end; + OS = record O, S : word; end; + +{$IFDEF Windows} +type + {$IFDEF Ver80} + Registers = DOSRegisters; {!!.04} + {$ELSE} + Registers = TRegisters; + {$ENDIF} + FileRec = TFileRec; +{$ENDIF} + +{=== Helper routines ===} + +function MinI(X, Y : integer) : integer; + {-Return minimum of X and Y} + inline($58/$5A/ {pop ax & dx} + $39/$D0/ {cmp ax, dx} + $7C/$01/ {jl @@exit} + $92 {xchg ax, dx} + ); {@@exit:} + +procedure CvtAsciizToStr(var Buffer; MaxStrLen : byte); + {-Convert an ASCIIZ string to a Pascal string in situ} + var + AZ : array [0..255] of char absolute Buffer; + S : string absolute Buffer; + i : integer; + begin + i := 0; + while (i < MaxStrLen) and (AZ[i] <> #0) do + inc(i); + Move(AZ[0], S[1], i); + S[0] := char(i); + end; + +procedure CvtStrToAsciiz(var Buffer; MaxStrLen : byte); + {-Convert Pascal string to an ASCIIZ string in situ} + var + AZ : array [0..255] of char absolute Buffer; + S : string absolute Buffer; + i : integer; + begin + i := MinI(MaxStrLen, length(S)); + if (i <> 0) then + Move(S[1], AZ[0], i); + AZ[i] := #0; + end; + +{$IFDEF DPMIorWnd} +function DOSGetMem(var RealPtr, ProtPtr; Size : word) : boolean; near; + var + RealMode : pointer absolute RealPtr; + ProtMode : pointer absolute ProtPtr; + AllocResult : longint; + begin + AllocResult := GlobalDOSAlloc(Size); + if (AllocResult <> 0) then + begin + RealMode := Ptr(LH(AllocResult).H, 0); + ProtMode := Ptr(LH(AllocResult).L, 0); + DOSGetMem := true; + end + else DOSGetMem := false; + end; + +function DOSFreeMem(ProtPtr : pointer) : boolean; near; + begin + DOSFreeMem := GlobalDOSFree(OS(ProtPtr).S) = 0; + end; +{$ENDIF} + +{=== Interfaced routines ===} + +function DosLockRec(var F; FilePosition, FileLength : longint) : word; + var + Regs : Registers; + begin + if (DOSMajor < 3) then + DosLockRec:= shErrBadDosVersion + else if (FileRec(F).Mode = fmClosed) then + DosLockRec := shErrFileNotOpen + else + begin + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ax := $5C00; + bx := FileRec(F).Handle; + cx := LH(FilePosition).H; + dx := LH(FilePosition).L; + si := LH(FileLength).H; + di := LH(FileLength).L; + Intr($21, Regs); + if not Odd(Flags) then + ax := 0; + DosLockRec := ax + end; + end; + end; + +function UnlockDosRec(var F; FilePosition, FileLength : longint) : word; + var + Regs : Registers; + begin + if (DOSMajor < 3) then + UnlockDosRec := shErrBadDosVersion + else if (FileRec(F).Mode = fmClosed) then + UnlockDosRec := shErrFileNotOpen + else + begin + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ax := $5C01; + bx := FileRec(F).Handle; + cx := LH(FilePosition).H; + dx := LH(FilePosition).L; + si := LH(FileLength).H; + di := LH(FileLength).L; + Intr($21, Regs); + if not Odd(Flags) then + ax := 0; + UnlockDosRec := ax + end; + end; + end; + +function UpdateFile(var F) : word; + var + Regs : Registers; + begin + if (FileRec(F).Mode = fmClosed) then + UpdateFile := shErrFileNotOpen + else if (DosMajor > 3) or ((DosMajor = 3) and (DosMinor >= 30)) then + begin + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ah := $68; {commit file} + bx := FileRec(F).Handle; + Intr($21, Regs); + if not Odd(Flags) then + ax := 0; + UpdateFile := ax + end; + end + else + begin + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ah := $45; {duplicate handle} + bx := FileRec(F).Handle; + Intr($21, Regs); + if Odd(Flags) then + UpdateFile := ax + else + begin + bx := ax; + ah := $3E; {close file handle} + Intr($21, Regs); + if not Odd(Flags) then + ax := 0; + UpdateFile := ax + end; + end; + end; + end; + +function GetExtendedError(var EClass, Action, Locus : byte) : word; + var + Regs : Registers; + begin + if (DosMajor < 3) then + GetExtendedError := shErrBadDosVersion + else + begin + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ah := $59; + Intr($21, Regs); + GetExtendedError := AX; + EClass := BH; + Action := BL; + Locus := CH; + end; + end; + end; + + +function IBMPCLanLoaded(var Lan : PCLanOpType) : boolean; + const + REDIRECTORFLAG = $0008; + RECEIVERFLAG = $0080; + MESSENGERFLAG = $0004; + SERVERFLAG = $0040; + var + {$IFDEF DPMIOrWnd} {!!.51} + Regs : DPMIRegisters; {!!.51} + {$ELSE} {!!.51} + Regs : Registers; + {$ENDIF} {!!.51} + begin + IBMPCLanLoaded := false; + Lan := LanUnknown; + if (DosMajor < 3) then + Exit; + with Regs do + begin + FillChar(Regs, sizeof(Regs), 0); + ax := $B800; + {$IFDEF DPMIorWnd} + SimulateRealModeInt($2F, Regs); {!!.51} + {$ELSE} + Intr($2F, Regs); + {$ENDIF} + if (al = 0) then + Exit; + IBMPCLanLoaded := true; + if ((bl and SERVERFLAG) <> 0) then + Lan := LanServer + else if ((bl and MESSENGERFLAG) <> 0) then + Lan := LanMessenger + else if ((bl and RECEIVERFLAG) <> 0) then + Lan := LanReceiver + else if ((bl and REDIRECTORFLAG) <> 0) then + Lan := LanRedirector; + end; + end; + +function IsDriveLocal(Drive : byte) : boolean; + var + Regs : Registers; + begin + IsDriveLocal := true; + if (DosMajor >= 3) then + begin + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ax := $4409; + bl := Drive; + Intr($21, Regs); + if not Odd(Flags) then + IsDriveLocal := (dx and $1000) = 0; + end; + end; + end; + +function IsFileLocal(var F) : boolean; + var + Regs : Registers; + begin + IsFileLocal := true; + if (DosMajor >= 3) then + begin + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ax := $440A; + bx := FileRec(F).Handle; + Intr($21, Regs); + if not Odd(Flags) then + IsFileLocal := (dx and $8000) = 0; + end; + end; + end; + +function ShareInstalled : boolean; + var + {$IFDEF DPMI} {!!.51} + Regs : DPMIRegisters; {!!.51} + {$ELSE} {!!.51} + Regs : Registers; + {$ENDIF} {!!.51} + begin + {Under Windows: + 1. VSHARE.386 can be present instead of SHARE.EXE, & DOS + boxes will even 'see' SHARE as being present. + 2. The pmode INT $2F call always returns true. + 3. The real mode INT $2F call will miss the presence of + VSHARE.386. + 4. Microsoft recommend that SHARE/VSHARE is loaded, and + many Windows programs won't work without it. + Hence this routine always returns true} + {$IFDEF Windows} {!!.51} + ShareInstalled := true; {!!.51} + {$ELSE} {!!.51} + ShareInstalled := false; + if (DosMajor >= 3) then + begin + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + AX := $1000; + {$IFDEF DPMI} {!!.51} + SimulateRealModeInt($2F, Regs); {!!.51} + {$ELSE} + Intr($2F, Regs); + {$ENDIF} + ShareInstalled := (AL = $FF); + end; + end; + {$ENDIF} {!!.51} + end; + +function GetPrinterSetup(var SetupStr : PrnSetupStr; RDLIndex : word) : word; + var + RealS: pointer; + St : ^string; + {$IFDEF DPMIorWnd} + Regs : DPMIRegisters; + {$ELSE} + Regs : Registers; + TempS: string; + {$ENDIF} + begin + if (DosMajor < 3) or ((DosMajor = 3) and (DosMinor < 10)) then + GetPrinterSetup := shErrBadDosVersion + else + begin + {$IFDEF DPMIorWnd} + if not DOSGetMem(RealS, St, SizeOf(PrnSetUpStr)) then + begin + GetPrinterSetup := shErrNoDosMemory; + Exit; + end; + {$ELSE} + St := @TempS; + RealS := St; + {$ENDIF} + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ax := $5E03; + bx := RDLIndex; + es := OS(RealS).S; + di := succ(OS(RealS).O); + {$IFDEF DPMIorWnd} + SimulateRealModeInt($21, Regs); + {$ELSE} + Intr($21, Regs); + {$ENDIF} + if Odd(Flags) then + GetPrinterSetUp := ax + else + begin + GetPrinterSetup := 0; + St^[0] := char(cx); + SetupStr := St^; + end; + end; + {$IFDEF DPMIorWnd} + if not DOSFreeMem(St) then + {nothing}; + {$ENDIF} + end; + end; + +function SetPrinterSetup(SetupStr : PrnSetupStr; RDLIndex : word) : word; + var + RealS: pointer; + {$IFDEF DPMIorWnd} + St : ^string; + Regs : DPMIRegisters; + {$ELSE} + Regs : Registers; + {$ENDIF} + begin + if (DosMajor < 3) or ((DosMajor = 3) and (DosMinor < 10)) then + SetPrinterSetup := shErrBadDosVersion + else + begin + {$IFDEF DPMIorWnd} + if not DOSGetMem(RealS, St, SizeOf(PrnSetupStr)) then + begin + SetPrinterSetup := shErrNoDosMemory; + Exit; + end; + St^ := SetupStr; + {$ELSE} + RealS := @SetupStr; + {$ENDIF} + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ax := $5E02; + bx := RDLIndex; + cx := length(SetupStr); + ds := OS(RealS).S; + si := succ(OS(RealS).O); + {$IFDEF DPMIorWnd} + SimulateRealModeInt($21, Regs); + {$ELSE} + Intr($21, Regs); + {$ENDIF} + if not Odd(Flags) then + ax := 0; + SetPrinterSetUp := ax + end; + {$IFDEF DPMIorWnd} + if not DOSFreeMem(St) then + {nothing}; + {$ENDIF} + end; + end; + +function GetMachineName(var MachineName : LocalStr; + var MachineNum : byte) : word; + var + RealS: pointer; + St : ^string; + {$IFDEF DPMIorWnd} + Regs : DPMIRegisters; + {$ELSE} + Regs : Registers; + TempS: LocalStr; + {$ENDIF} + begin + MachineName := ''; + MachineNum := 0; + if (DosMajor < 3) or ((DosMajor = 3) and (DosMinor < 10)) then + GetMachineName := shErrBadDosVersion + else + begin + {$IFDEF DPMIorWnd} + if not DOSGetMem(RealS, St, SizeOf(LocalStr)) then {!!.51} + begin + GetMachineName := shErrNoDosMemory; + Exit; + end; + {$ELSE} + St := @TempS; + RealS := St; + {$ENDIF} + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ax := $5E00; + ds := OS(RealS).S; + dx := OS(RealS).O; {!!.51} + {$IFDEF DPMIorWnd} + SimulateRealModeInt($21, Regs); + {$ELSE} + Intr($21, Regs); + {$ENDIF} + if Odd(Flags) then + GetMachineName := ax + else + begin + GetMachineName := 0; + {$IFDEF DPMIorWnd} + if (Hi(LH(cx).L) <> 0) then + {$ELSE} + if (ch <> 0) then + {$ENDIF} + begin {(ch <> 0) => machine name is defined} + CvtAsciizToStr(St^, pred(sizeof(LocalStr))); + MachineName := St^; + MachineNum := cx and $FF; + end; + end; + end; + {$IFDEF DPMIorWnd} + if not DOSFreeMem(St) then + {nothing}; + {$ENDIF} + end; + end; + +function GetTempFileName(PathName : string; + var TempFileName : string) : word; + var + RealS: pointer; + St : ^string; + {$IFDEF DPMIorWnd} + Regs : DPMIRegisters; + {$ELSE} + Regs : Registers; + TempS: string; + {$ENDIF} + begin + TempFileName := ''; + if (DosMajor < 3) then + GetTempFileName := shErrBadDosVersion + else + begin + {$IFDEF DPMIorWnd} + if not DOSGetMem(RealS, St, SizeOf(string)) then + begin + GetTempFileName := shErrNoDosMemory; + Exit; + end; + {$ELSE} + St := @TempS; + RealS := St; + {$ENDIF} + St^ := PathName; + CvtStrToAsciiz(St^, pred(sizeof(string))); + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ax := $5A00; + {cx := 0;} + ds := OS(RealS).S; + dx := OS(RealS).O; + {$IFDEF DPMIorWnd} + SimulateRealModeInt($21, Regs); + {$ELSE} + Intr($21, Regs); + {$ENDIF} + if Odd(Flags) then + GetTempFileName := ax + else + begin + bx := ax; + ax := $3E00; {close file handle} + {$IFDEF DPMIorWnd} + SimulateRealModeInt($21, Regs); + {$ELSE} + Intr($21, Regs); + {$ENDIF} + if not Odd(Flags) then + ax := 0; + GetTempFileName := ax; + CvtAsciizToStr(St^, pred(sizeof(string))); + TempFileName := St^; + end; + end; + {$IFDEF DPMIorWnd} + if not DOSFreeMem(St) then + {nothing}; + {$ENDIF} + end; + end; + +function CancelRedirection(LocalName : LocalStr) : word; + var + RealS: pointer; + St : ^string; + {$IFDEF DPMIorWnd} + Regs : DPMIRegisters; + {$ELSE} + Regs : Registers; + {$ENDIF} + begin + if (DosMajor < 3) or ((DosMajor = 3) and (DosMinor < 10)) then + CancelRedirection := shErrBadDosVersion + else + begin + {$IFDEF DPMIorWnd} + if not DOSGetMem(RealS, St, SizeOf(LocalStr)) then + begin + CancelRedirection := shErrNoDosMemory; + Exit; + end; + St^ := LocalName; + {$ELSE} + RealS := @LocalName; + St := RealS; + {$ENDIF} + CvtStrToAsciiz(St^, pred(sizeof(LocalStr))); + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ax := $5F04; + ds := OS(RealS).S; + si := OS(RealS).O; + {$IFDEF DPMIorWnd} + SimulateRealModeInt($21, Regs); + {$ELSE} + Intr($21, Regs); + {$ENDIF} + if not Odd(Flags) then + ax := 0; + CancelRedirection := ax; + end; + {$IFDEF DPMIorWnd} + if not DOSFreeMem(St) then + {nothing}; + {$ENDIF} + end; + end; + + +function GetRedirectionEntry(RDLIndex : Word; + var LocalName : LocalStr; + var NetworkName: NetworkStr; + var Parameter : word; + var Dev : DeviceType) : word; + type + PRedir = ^TRedir; + TRedir = record + Local : LocalStr; + Network : NetworkStr; + end; + var + RealData : pointer; + RedirData: PRedir; + {$IFDEF DPMIorWnd} + Regs : DPMIRegisters; + {$ELSE} + Regs : Registers; + TempData : TRedir; + {$ENDIF} + begin + if (DosMajor < 3) or ((DosMajor = 3) and (DosMinor < 10)) then + GetRedirectionEntry := shErrBadDosVersion + else + begin + {$IFDEF DPMIorWnd} + if not DOSGetMem(RealData, RedirData, SizeOf(TRedir)) then + begin + GetRedirectionEntry := shErrNoDosMemory; + Exit; + end; + {$ELSE} + RedirData := @TempData; + RealData := RedirData; + {$ENDIF} + FillChar(RedirData^, sizeof(TRedir), 0); + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ax := $5F02; + bx := RDLIndex; + ds := OS(RealData).S; + si := OS(RealData).O; + es := OS(RealData).S; + di := OS(RealData).O + sizeof(LocalStr); + {$IFDEF DPMIorWnd} + SimulateRealModeInt($21, Regs); + {$ELSE} + Intr($21, Regs); + {$ENDIF} + if Odd(Flags) then + GetRedirectionEntry := ax + else + begin + GetRedirectionEntry := 0; + if ((bx and $10) = 0) then + if ((bx and $0F) = 3) then + Dev := DevPrinter + else Dev := DevDrive + else Dev := DevInvalid; + Parameter := cx; + with RedirData^ do + begin + CvtAsciizToStr(Local, pred(sizeof(LocalStr))); + LocalName := Local; + CvtAsciizToStr(Network, pred(sizeof(NetworkStr))); + NetworkName := Network; + end; + end; + end; + {$IFDEF DPMIorWnd} + if not DOSFreeMem(RedirData) then + {nothing}; + {$ENDIF} + end; + end; + +function RedirectDevice(TypeOfDev : DeviceType; + LocalName : LocalStr; + NetworkName: NetworkStr; + Password : NetworkStr; + Parameter : word) : word; + type + PRedir = ^TRedir; + TRedir = record + Local : LocalStr; + Network : string; + end; + var + RealData : pointer; + RedirData: PRedir; + {$IFDEF DPMIorWnd} + Regs : DPMIRegisters; + {$ELSE} + Regs : Registers; + TempData : TRedir; + {$ENDIF} + begin + if (DosMajor < 3) or ((DosMajor = 3) and (DosMinor < 10)) then + RedirectDevice := shErrBadDosVersion + else + begin + {$IFDEF DPMIorWnd} + if not DOSGetMem(RealData, RedirData, SizeOf(TRedir)) then + begin + RedirectDevice := shErrNoDosMemory; + Exit; + end; + {$ELSE} + RedirData := @TempData; + RealData := RedirData; + {$ENDIF} + FillChar(RedirData^, sizeof(TRedir), 0); + with RedirData^ do + begin + Local := LocalName; + CvtStrToAsciiz(Local, pred(sizeof(LocalStr))); {!!.51} + Network := NetworkName + #0 + Password; + CvtStrToAsciiz(Network, pred(sizeof(string))); {!!.51} + end; + FillChar(Regs, sizeof(Regs), 0); + with Regs do + begin + ax := $5F03; + if (TypeOfDev = DevPrinter) then + bx := 3 + else bx := 4; + cx := Parameter; + ds := OS(RealData).S; + si := OS(RealData).O; + es := OS(RealData).S; + di := OS(RealData).O + sizeof(LocalStr); + {$IFDEF DPMIorWnd} + SimulateRealModeInt($21, Regs); + {$ELSE} + Intr($21, Regs); + {$ENDIF} + if not Odd(Flags) then + ax := 0; + RedirectDevice := ax + end; + {$IFDEF DPMIorWnd} + if not DOSFreeMem(RedirData) then + {nothing}; + {$ENDIF} + end; + end; + +var + DosVer : word; +begin + DosVer := DosVersion; + DosMajor := Lo(DosVer); + DosMinor := Hi(DosVer); +end. + diff --git a/src/wc_sdk/tpalloc.pas b/src/wc_sdk/tpalloc.pas new file mode 100644 index 0000000..47b5eb9 --- /dev/null +++ b/src/wc_sdk/tpalloc.pas @@ -0,0 +1,526 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{$S-,R-,I-,V-,B-,F-} + +{won't work under Windows} +{$IFDEF Windows} + **ERROR** Not compatible with Turbo Pascal for Windows +{$ENDIF} +{$IFDEF DPMI} + **ERROR** Not compatible with Turbo Pascal DPMI +{$ENDIF} + +{$IFNDEF Ver40} + {Allow overlays} + {$F+,A-,O+} +{$ENDIF} + +{Activates different code for TP6 heap manager} +{$DEFINE Heap6} +{$IFDEF Ver50} + {$UNDEF Heap6} +{$ENDIF} +{$IFDEF Ver55} + {$UNDEF Heap6} +{$ENDIF} + +unit TpAlloc; + {-Routines for allocating/deallocating blocks of memory larger than 64K} + +interface + +type + SegOfs = {structure of a pointer} + record + Ofst, Segm : Word; + end; + + {----- memory management routines -----} + +procedure HugeGetMem(var Pt; Bytes : LongInt); + {-Allocate a block of memory of size Bytes and store pointer to it in + Pt. Pt is nil if Bytes > MaxAvail} + +procedure HugeFreeMem(var Pt; Bytes : LongInt); + {-Deallocate a block of memory of size Bytes pointed to by Pt, a pointer + variable. Pt is set to nil on Exit. Does nothing if Pt is nil.} + + {----- pointer manipulation routines -----} + +function Linear(P : Pointer) : LongInt; + {-Converts a pointer to a linear address to allow differences in addresses + to be calculated. The pointer must be in the range $0:$0 to $FFFF:$000F.} + +function LinearToPointer(L : LongInt) : Pointer; + {-Return linear address L as a normalized pointer} + +function PtrDiff(P1, P2 : Pointer) : LongInt; + {-Return the number of bytes between P1^ and P2^} + +function Normalized(P : Pointer) : Pointer; + {-Return P as a normalized pointer} + inline( + $58/ {pop ax ;pop offset into AX} + $5A/ {pop dx ;pop segment into DX} + $89/$C3/ {mov bx,ax ;BX = Ofs(P^)} + $B1/$04/ {mov cl,4 ;CL = 4} + $D3/$EB/ {shr bx,cl ;BX = Ofs(P^) div 16} + $01/$DA/ {add dx,bx ;add BX to segment} + $25/$0F/$00); {and ax,$F ;mask out unwanted bits in offset} + + {=============================================================} + +implementation + +type + FreeListRecPtr = ^FreeListRec; + FreeListRec = {structure of a free list entry} + record + {$IFDEF Heap6} + Next : FreeListRecPtr; {pointer to next free list record} + Size : Pointer; {"normalized pointer" representing size} + {$ELSE} + OrgPtr : Pointer; {pointer to the start of the block} + EndPtr : Pointer; {pointer to the end of the block} + {$ENDIF} + end; + + function Linear(P : Pointer) : LongInt; + {-Converts a pointer to a linear address to allow differences in addresses + to be calculated. The pointer must be in the range $0:$0 to $FFFF:$000F.} + begin + with SegOfs(P) do + Linear := (LongInt(Segm) shl 4)+LongInt(Ofst); + end; + + function LinearToPointer(L : LongInt) : Pointer; + {-Return linear address L as a normalized pointer} + begin + LinearToPointer := Ptr(Word(L shr 4), Word(L and $0000000F)); + end; + + function PtrDiff(P1, P2 : Pointer) : LongInt; + {-Return the number of bytes between P1^ and P2^} + begin + PtrDiff := Abs(Linear(P1)-Linear(P2)); + end; + +{$IFDEF Heap6} + + procedure HugeGetMem(var Pt; Bytes : LongInt); + {-Allocate a block of memory of size Bytes and store pointer to it in + Pt. Pt is nil if Bytes > MaxAvail} + var + ThisP : Pointer absolute Pt; + P : FreeListRecPtr; + Prev : FreeListRecPtr; + ThisBlock : LongInt; + begin + {initialize in case of failure} + ThisP := nil; + + {round bytes up to multiple of 8} + Bytes := (Bytes+7) and $FFFFFFF8; + + {scan the free list} + P := FreeList; + Prev := nil; + while P <> HeapPtr do begin + {get the size of this block} + ThisBlock := Linear(P^.Size); + if ThisBlock > Bytes then begin + {block is bigger than we need, shrink the size} + dec(ThisBlock, Bytes); + ThisP := LinearToPointer(Linear(P)+ThisBlock); + P^.Size := LinearToPointer(ThisBlock); + Exit; + end else if ThisBlock = Bytes then begin + {this block is just right, remove it from list} + ThisP := P; + if Prev = nil then + FreeList := P^.Next + else + Prev^.Next := P^.Next; + Exit; + end; + {next free list record} + Prev := P; + P := P^.Next; + end; + + {check block at HeapPtr^} + if PtrDiff(HeapEnd, HeapPtr) >= Bytes then begin + {use this block} + ThisP := HeapPtr; + {adjust HeapPtr} + HeapPtr := LinearToPointer(Linear(HeapPtr)+Bytes); + {adjust free list} + if Prev = nil then + FreeList := HeapPtr + else + Prev^.Next := HeapPtr; + end; + end; + + procedure HugeFreeMem(var Pt; Bytes : LongInt); + {-Deallocate a block of memory of size Bytes pointed to by Pt, a pointer + variable. Pt is set to nil on Exit. Does nothing if Pt is nil.} + label + ExitPoint; + var + ThisP : FreeListRecPtr absolute Pt; + ThisL : LongInt; + ThisE : LongInt; + BytesP : Pointer; + P : FreeListRecPtr; + PL : LongInt; + Prev : FreeListRecPtr; + + procedure MergeThisWithNext; + var + PSize : LongInt; + begin + if ThisE > PL then + {this block overlaps next one} + RunError(204) + else if ThisE = PL then begin + {this block merges into next one} + ThisP^.Next := P^.Next; + PSize := Linear(P^.Size); + inc(ThisE, PSize); + ThisP^.Size := LinearToPointer(PSize+Bytes); + end else begin + {link new block into chain} + ThisP^.Next := P; + ThisP^.Size := BytesP; + end; + end; + + procedure MergePrevWithThis; + var + PrevL : LongInt; + PrevSize : LongInt; + begin + PrevSize := Linear(Prev^.Size); + PrevL := Linear(Prev); + if PrevL+PrevSize > ThisL then + {previous block overlaps this one} + RunError(204) + else if PrevL+PrevSize = ThisL then begin + {previous block merges into this one} + inc(Bytes, PrevSize); + BytesP := LinearToPointer(Bytes); + Prev^.Size := BytesP; + {refer to previous block for further merging} + ThisP := Prev; + ThisL := PrevL; + end else + {link new block into chain} + Prev^.Next := ThisP; + end; + + procedure MergeThisWithFree; + var + HL : LongInt; + P : FreeListRecPtr; + begin + HL := Linear(HeapPtr); + if ThisE > HL then + {this block overlaps the free heap} + RunError(204) + else if ThisE = HL then begin + {this block merges into HeapPtr} + HeapPtr := ThisP; + if (Prev <> nil) and (ThisP <> Prev) then + {link new block into chain} + Prev^.Next := HeapPtr + else if (Prev = nil) or (Prev = FreeList) then + {no more free blocks} + FreeList := HeapPtr + else begin + {need to find Prev's predecessor} + P := FreeList; + while P^.Next <> Prev do + P := P^.Next; + P^.Next := Prev; + end; + end else begin + {this is the new top block} + if Prev = nil then + FreeList := ThisP + else + Prev^.Next := ThisP; + ThisP^.Next := HeapPtr; + ThisP^.Size :=BytesP; + end; + end; + + begin + {exit if pointer is nil or no bytes requested} + if (ThisP = nil) or (Bytes = 0) then + Exit; + + {error if pointer offset is not 0 or 8} + if (SegOfs(ThisP).Ofst <> 0) and (SegOfs(ThisP).Ofst <> 8) then + RunError(204); + + {error if block is below the heap} + if SegOfs(ThisP).Segm < SegOfs(HeapOrg).Segm then + RunError(204); + {block above HeapPtr is checked later} + + {round bytes up to multiple of 8} + Bytes := (Bytes+7) and $FFFFFFF8; + BytesP := LinearToPointer(Bytes); + + {get the pointer in linear format} + ThisL := Linear(ThisP); + ThisE := ThisL+Bytes; + + {scan the free list} + P := FreeList; + Prev := nil; + while P <> HeapPtr do begin + PL := Linear(P); + if PL = ThisL then + {freeing an already freed block} + RunError(204) + else if PL > ThisL then begin + {passed the new block, time to merge it} + if Prev = nil then begin + {new block is lower than any existing block} + MergeThisWithNext; + FreeList := ThisP; + end else begin + {new block is between two existing blocks} + MergePrevWithThis; + MergeThisWithNext; + end; + goto ExitPoint; + end; + {next free list record} + Prev := P; + P := P^.Next; + end; + + {new block is higher than any existing block} + if Prev <> nil then + {this block is after at least one other free block} + MergePrevWithThis; + MergeThisWithFree; + +ExitPoint: + ThisP := nil; + end; + +{$ELSE} + + procedure HugeGetMem(var Pt; Bytes : LongInt); + {-Allocate a block of memory of size Bytes and store pointer to it in + Pt. Pt is nil if Bytes > MaxAvail} + var + ThisP : Pointer absolute Pt; + P : FreeListRecPtr; + Top : Pointer; + ThisBlock : LongInt; + begin + ThisP := nil; + + {point to end of free list} + P := FreePtr; + if SegOfs(P).Ofst = 0 then + Inc(SegOfs(P).Segm, $1000); + + {point to top of free memory} + if FreeMin = 0 then + Top := Ptr(SegOfs(FreePtr).Segm+$1000, 0) + else + Top := Ptr(SegOfs(FreePtr).Segm, -FreeMin); + if Linear(P) < Linear(Top) then + Top := P; + + {check block at HeapPtr^} + if PtrDiff(Top, HeapPtr) >= Bytes then begin + {use this block} + ThisP := HeapPtr; + + {adjust HeapPtr} + HeapPtr := LinearToPointer(Linear(HeapPtr)+Bytes); + end + else while SegOfs(P).Ofst <> 0 do begin + {search the free list for a memory block that is big enough} + with P^ do begin + {calculate the size of the block} + ThisBlock := PtrDiff(EndPtr, OrgPtr); + + if ThisBlock > Bytes then begin + {bigger than we need--shrink the size of the block} + ThisP := OrgPtr; + OrgPtr := LinearToPointer(Linear(OrgPtr)+Bytes); + Exit; + end + else if ThisBlock = Bytes then begin + {exact size--remove the record from the free list} + ThisP := OrgPtr; + + {move the entry at the bottom of the free list up} + P^ := FreeListRecPtr(FreePtr)^; + + {adjust FreePtr} + with SegOfs(FreePtr) do + Inc(Ofst, SizeOf(FreeListRec)); + + Exit; + end; + end; + + {point to next record on free list} + Inc(SegOfs(P).Ofst, SizeOf(FreeListRec)); + end; + end; + + procedure HugeFreeMem(var Pt; Bytes : LongInt); + {-Deallocate a block of memory of size Bytes pointed to by Pt, a pointer + variable. Pt is set to nil on Exit. Does nothing if Pt is nil.} + var + P : Pointer absolute Pt; + EndP : Pointer; + FP, SaveFP, NewFreePtr : FreeListRecPtr; + I : Word; + Found : Boolean; + begin + {exit if P is nil} + if (P = nil) then + Exit; + + {calculate pointer to end of block} + EndP := LinearToPointer(Linear(P)+Bytes); + + {see if this is just below HeapPtr^} + if EndP = HeapPtr then + {just reset HeapPtr} + HeapPtr := P + else begin + {search for a free list entry to combine this block with} + Found := False; + FP := FreePtr; + while (SegOfs(FP).Ofst <> 0) and not Found do begin + with FP^ do + {does the end of our block match the start of this one?} + if OrgPtr = EndP then begin + OrgPtr := P; + Found := True; + end + {does the start of our block match the end of this one?} + else if EndPtr = P then begin + EndPtr := EndP; + Found := True; + end; + + {point to next record on free list} + if not Found then + Inc(SegOfs(FP).Ofst, SizeOf(FreeListRec)); + end; + + if Found then begin + {save pointer into free list and get pointers to search for} + SaveFP := FP; + with FP^ do begin + P := OrgPtr; + EndP := EndPtr; + end; + + {see if we can combine this block with a second} + Found := False; + FP := FreePtr; + while (SegOfs(FP).Ofst <> 0) and not Found do begin + with FP^ do + {does the end of our block match the start of this one?} + if OrgPtr = EndP then begin + OrgPtr := P; + Found := True; + end + {does the start of our block match the end of this one?} + else if EndPtr = P then begin + EndPtr := EndP; + Found := True; + end; + + {point to next record on free list} + if not Found then + Inc(SegOfs(FP).Ofst, SizeOf(FreeListRec)); + end; + + if Found then begin + {we combined two blocks--get rid of the 1st free list entry we found} + + {move the entry at the bottom of the free list up into its place} + SaveFP^ := FreeListRecPtr(FreePtr)^; + + {adjust FreePtr} + with SegOfs(FreePtr) do + Inc(Ofst, SizeOf(FreeListRec)); + end; + end + else begin + {can't combine with anything--add an entry to the free list} + + {calculate new FreePtr} + with SegOfs(FreePtr) do + NewFreePtr := Ptr(Segm, Ofst-SizeOf(FreeListRec)); + + {make sure the free list isn't full} + with SegOfs(NewFreePtr) do + if (Linear(NewFreePtr) < Linear(HeapPtr)) or (Ofst = 0) then begin + {it's full--let real FreeMem generate a runtime error} + if Bytes > 65521 then + I := 65521 + else + I := Bytes; + FreeMem(P, I); + Exit; + end; + + {fill in the new free list entry} + with NewFreePtr^ do begin + OrgPtr := P; + EndPtr := EndP; + end; + + {adjust FreePtr} + FreePtr := NewFreePtr; + end; + + {set P to nil} + P := nil; + end; + end; + +{$ENDIF} + +end. diff --git a/src/wc_sdk/tpcmd.pas b/src/wc_sdk/tpcmd.pas new file mode 100644 index 0000000..a9b2701 --- /dev/null +++ b/src/wc_sdk/tpcmd.pas @@ -0,0 +1,540 @@ +{$S-,R-,V-,I-,B-,F-} + +{$IFNDEF Ver40} + {$S-,O-,A-} +{$ENDIF} +{$I tpdefine.inc} {!!.21} + +{*********************************************************} +{* TPCMD.PAS 5.22 *} +{*********************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Portions Copyright (c) Sunny Hill Software 1995, 1996 + * and used under license to TurboPower Software + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +unit TpCmd; + {-Convert keystrokes to commands. This unit is intended primarily for + internal use.} + +interface + +type + MatchType = (NoMatch, PartMatch, FullMatch); +const + NoCmd = 0; {Returned by GetCommand for invalid keystroke} + AlphaCmd = 1; {Returned by GetCommand for alphanumeric char} + MapWordStar : Boolean = True; {True to map second character to control char} + +{************************************************************** + KeySet is an array of byte, in the following form: + (LengthByte, Key1, Key2, ..., CommandOrd, + ..., + 0); + LengthByte includes the number of keys plus 1 for CommandOrd. +**************************************************************} + +function GetCommand(var KeySet; KeyPtr : Pointer; var ChWord : Word) : Byte; + {-Get next command or character} + +function AddCommandPrim(var KeySet; + LastKeyIndex : Word; + Cmd, NumKeys : Byte; + Key1, Key2 : Word) : Boolean; + {-Add a new command key assignment or change an existing one} + +procedure GetKeysForCommand(var KeySet; + Cmd : Byte; + var NumKeys : Byte; + var Key1, Key2 : Word); + {-Search KeySet for Cmd, returning first set of matching keys. + NumKeys = 0 if no match found} + + {--- the following routines, etc. are for installation programs ---} +const + MaxKeys = 300; + MaxCommands = 150; + KeyLength = 6; +type + KeyString = string[KeyLength]; + KeyRec = + record + Modified : Boolean; + Conflict : Boolean; + CommandCode : Byte; + Keys : KeyString; + end; + UnpackedKeyArray = array[1..MaxCommands] of KeyRec; + UnpackedKeyPtr = ^UnpackedKeyArray; + PackedKeyArray = array[0..MaxKeys] of Byte; + PackedKeyPtr = ^PackedKeyArray; + +function UnpackKeys(var PackedKeys, UnpackedKeys; + MaxCmds : Word; Cols : Byte) : Word; + {-Unpack keys into a fixed element array. Returns number of commands in + PackedKeys.} + +function PackKeys(var PackedKeys; NumCmds, MaxBytes : Word; + var UnpackedKeys) : Word; + {-Convert fixed array into a packed list of keys again. Returns the number + of keys that we *wanted* to store. Error if that number is greater than + MaxBytes.} + +function SizeKeys(var UnpackedKeys; NumCmds : Word) : Word; + {-Return number of bytes in packed version of UnpackedKeys} + +function ConflictsFound(var UnpackedKeys; NumCmds : Word) : Boolean; + {-Check UnpackedKeys for conflicts. Returns True if Conflicts were found} + + {--- the following routine is intended for internal use ---} + +function CheckForKeyConflict(var KeySet; + LastKeyIndex : Word; + Cmd, NumKeys : Byte; + Key1, Key2 : Word) : MatchType; + {-Check to see if the specified key combination conflicts with an existing + one} + + {======================================================} + +implementation + +type + KeyArray = array[0..32000] of Byte; + KeyArrayPtr = ^KeyArray; + CmdBuffArray = array[0..5] of Byte; + + function WordStarCommand(K : Byte) : Byte; + {-Return ^C, 'C', or 'c' as ^C, etc.} + var + C : Char absolute K; + begin + C := Upcase(C); + case C of + 'A'..'_' : + WordStarCommand := K-64; + else + WordStarCommand := K; + end; + end; + + function ScanCommands(K : KeyArrayPtr; + var CmdBuffer : CmdBuffArray; + BufNext : Word; + var Cmd : Byte; + var FoundAt : Word) : MatchType; + {-Scan K^ for a match on CmdBuffer} + var + BufIndex : Word; + CmdIndex : Word; + CmdLen : Byte; + Matching : Boolean; + begin + Cmd := NoCmd; + CmdIndex := 0; + CmdLen := K^[CmdIndex]; + + {Scan the command list} + while CmdLen <> 0 do begin + FoundAt := CmdIndex; + Inc(CmdIndex); + BufIndex := 0; + Matching := True; + while Matching and (BufIndex < BufNext) and (BufIndex < CmdLen-1) do + if CmdBuffer[BufIndex] = K^[CmdIndex+BufIndex] then + Inc(BufIndex) + else + Matching := False; + if not Matching then begin + {No match, try next command} + Inc(CmdIndex, CmdLen); + CmdLen := K^[CmdIndex]; + end else begin + if BufNext = CmdLen-1 then begin + {Complete match} + ScanCommands := FullMatch; + Cmd := K^[CmdIndex+BufIndex]; + end else + ScanCommands := PartMatch; + Exit; + end; + end; + + {No match if we get here} + ScanCommands := NoMatch; + end; + + function GetCommand(var KeySet; KeyPtr : Pointer; var ChWord : Word) : Byte; + {-Get next command or character. + Returns NoCmd for no matching command, AlphaCmd for alphabetic character.} + var + LCh : Byte; + Cmd : Byte; + Junk : Word; + BufNext : Word; + Done : Boolean; + CmdBuffer : CmdBuffArray; + + function GetKeyWord : Word; + {-Call routine pointed to by KeyPtr} + inline($FF/$5E/ 0) and MapWordStar then + {Map WordStar keystrokes} + LCh := WordStarCommand(LCh); + CmdBuffer[BufNext] := LCh; + Inc(BufNext); + + {Map to a command} + case ScanCommands(@KeySet, CmdBuffer, BufNext, Cmd, Junk) of + FullMatch : Done := True; + NoMatch : + begin + {Return alphanumeric character if it isn't a command} + if (BufNext = 1) and (Char(LCh) >= ' ') and (Char(LCh) <> #127) then + Cmd := AlphaCmd; + Done := True; + end; + end; + until Done; + + GetCommand := Cmd; + end; + + procedure InitCmdBuffer(var CmdBuffer : CmdBuffArray; + NumKeys : Byte; + Key1, Key2 : Word; + var BufNext : Word); + {-Initialize a CmdBuffArray} + begin + if Lo(Key1) = 0 then begin + CmdBuffer[0] := 0; + CmdBuffer[1] := Hi(Key1); + BufNext := 2; + end + else begin + CmdBuffer[0] := Lo(Key1); + BufNext := 1; + end; + if NumKeys = 2 then + if Lo(Key2) = 0 then begin + CmdBuffer[BufNext] := 0; + Inc(BufNext); + CmdBuffer[BufNext] := Hi(Key2); + Inc(BufNext); + end + else begin + CmdBuffer[BufNext] := Lo(Key2); + Inc(BufNext); + end; + end; + + function CheckForKeyConflict(var KeySet; + LastKeyIndex : Word; + Cmd, NumKeys : Byte; + Key1, Key2 : Word) : MatchType; + {-Check to see if the specified key combination conflicts with an existing + one} + var + MT : MatchType; + BufNext : Word; + CTmp : Byte; + FoundAt : Word; + CmdBuffer : CmdBuffArray; + begin + if NumKeys = 0 then + MT := NoMatch + else begin + {set up for the search} + InitCmdBuffer(CmdBuffer, NumKeys, Key1, Key2, BufNext); + + {check for duplicate} + MT := ScanCommands(@KeySet, CmdBuffer, BufNext, CTmp, FoundAt); + end; + + CheckForKeyConflict := MT; + end; + + function AddCommandPrim(var KeySet; + LastKeyIndex : Word; + Cmd, NumKeys : Byte; + Key1, Key2 : Word) : Boolean; + {-Add a new command key assignment or change an existing one} + var + EditKeys : KeyArray absolute KeySet; + CTmp : Byte; + SlotFound : Boolean; + CmdLen, + FoundAt : Word; + MT : MatchType; + NextCmdIndex : Word; + BufNext : Word; + CmdBuffer : CmdBuffArray; + begin + AddCommandPrim := False; + if (NumKeys < 1) or (NumKeys > 2) then + Exit; + + {set up for the search} + InitCmdBuffer(CmdBuffer, NumKeys, Key1, Key2, BufNext); + + {check for duplicate} + MT := ScanCommands(@KeySet, CmdBuffer, BufNext, CTmp, FoundAt); + case MT of + FullMatch : + begin + {change the command} + CmdLen := EditKeys[FoundAt]; + if Cmd = NoCmd then begin + {Disable the keystrokes as well} + NextCmdIndex := FoundAt+1; + while NextCmdIndex < FoundAt+CmdLen do begin + EditKeys[NextCmdIndex] := $FF; + Inc(NextCmdIndex); + end; + end; + EditKeys[FoundAt+CmdLen] := Cmd; + AddCommandPrim := True; + Exit; + end; + PartMatch : + Exit; + end; + + {find next available command slot} + NextCmdIndex := 0; + SlotFound := False; + while not SlotFound and (EditKeys[NextCmdIndex] <> 0) do begin + CmdLen := EditKeys[NextCmdIndex]; + if EditKeys[NextCmdIndex+CmdLen] = NoCmd then + {Command slot is available for reuse} + if BufNext+1 = CmdLen then + {Slot is the right size} + SlotFound := True; + if not SlotFound then + Inc(NextCmdIndex, EditKeys[NextCmdIndex]+1); + end; + + {make sure it will fit} + if (BufNext+2) <= (LastKeyIndex-NextCmdIndex) then begin + {plug in the key} + EditKeys[NextCmdIndex] := BufNext+1; + Inc(NextCmdIndex); + Move(CmdBuffer, EditKeys[NextCmdIndex], BufNext); + Inc(NextCmdIndex, BufNext); + EditKeys[NextCmdIndex] := Cmd; + Inc(NextCmdIndex); + + AddCommandPrim := True; + end; + end; + + procedure GetKeysForCommand(var KeySet; + Cmd : Byte; + var NumKeys : Byte; + var Key1, Key2 : Word); + {-Search KeySet for Cmd, returning first set of matching keys. + NumKeys = 0 if no match found} + var + Keys : KeyArray absolute KeySet; + Kofs : Word; + TKey : Word; + Klen : Integer; + begin + NumKeys := 0; + Kofs := 0; + repeat + Klen := Keys[Kofs]; + if Klen <> 0 then + if Keys[Kofs+Klen] = Cmd then begin + {Matches command} + {Reduce length by one to avoid Cmd} + Dec(Klen); + repeat + {Get next key byte} + Inc(Kofs); + Dec(Klen); + if Keys[Kofs] = 0 then begin + {Extended keystroke} + Inc(Kofs); + Dec(Klen); + TKey := Word(Keys[Kofs]) shl 8; + end else + {Normal keystroke} + TKey := Keys[Kofs]; + + {Store the keys} + Inc(NumKeys); + if NumKeys = 1 then + Key1 := TKey + else if NumKeys = 2 then + Key2 := TKey; + until Klen <= 0; + + {Don't allow more than two keys} + if NumKeys > 2 then + NumKeys := 2; + Exit; + end; + Inc(Kofs, Klen+1); + until Klen = 0; + {No match} + end; + + function UnpackKeys(var PackedKeys, UnpackedKeys; + MaxCmds : Word; Cols : Byte) : Word; + {-Unpack keys into a fixed element array. Returns number of commands in + PackedKeys.} + var + PK : PackedKeyArray absolute PackedKeys; + UK : UnpackedKeyArray absolute UnpackedKeys; + Count, CmdNum, KeyOfs : Word; + I, Len : Word; + label + Done; + begin + if Cols = 0 then + Cols := 1; + FillChar(UK, MaxCmds*SizeOf(KeyRec), 0); + for I := 1 to MaxCmds do + with UK[I] do + CommandCode := (Pred(I) div Cols)+1; + KeyOfs := 0; + Count := 0; + while PK[KeyOfs] <> 0 do begin + Inc(Count); + Len := PK[KeyOfs]; + + {find an unused entry in the proper row} + CmdNum := Word(PK[KeyOfs+Len]-1)*3+1; + for I := 1 to Cols do + with UK[CmdNum] do + if Length(Keys) = 0 then + with UK[CmdNum] do begin + Move(PK[KeyOfs], Keys, Len); + Dec(Keys[0]); + goto Done; + end + else + Inc(CmdNum); +Done: + Inc(KeyOfs, Len+1); + end; + + UnpackKeys := Count; + end; + + function PackKeys(var PackedKeys; NumCmds, MaxBytes : Word; + var UnpackedKeys) : Word; + {-Convert fixed array into a packed list of keys again. Returns the number + of keys that we *wanted* to store. Error if that number is greater than + MaxBytes.} + var + PK : PackedKeyArray absolute PackedKeys; + UK : UnpackedKeyArray absolute UnpackedKeys; + Len : Byte; + CmdNum : Word; + KeyOfs : Word; + KeyNew : Word; + begin + FillChar(PK, MaxBytes, 0); + KeyOfs := 0; + for CmdNum := 1 to NumCmds do + with UK[CmdNum] do + if Length(Keys) <> 0 then begin + Len := Length(Keys)+1; + KeyNew := KeyOfs+Len+1; + if KeyNew <= MaxBytes then begin + {Store the keys if they fit} + Inc(Keys[0]); + Move(Keys, PK[KeyOfs], Len); + PK[KeyNew-1] := CommandCode; + end; + KeyOfs := KeyNew; + end; + + {Return the number of keys we wanted to store} + PackKeys := KeyOfs; + end; + + function SizeKeys(var UnpackedKeys; NumCmds : Word) : Word; + {-Return number of bytes in packed version of UnpackedKeys} + var + UK : UnpackedKeyArray absolute UnpackedKeys; + CmdNum : Word; + Size : Word; + begin + Size := 0; + for CmdNum := 1 to NumCmds do + with UK[CmdNum] do + if Length(Keys) <> 0 then + Inc(Size, Length(Keys)+2); + SizeKeys := Size; + end; + + function ConflictsFound(var UnpackedKeys; NumCmds : Word) : Boolean; + {-Check UnpackedKeys for conflicts. Returns False if Conflicts found} + var + I, J : Word; + UK : UnpackedKeyArray absolute UnpackedKeys; + begin + {assume success} + ConflictsFound := False; + + {turn off all Conflict flags} + for I := 1 to NumCmds do + UK[I].Conflict := False; + + {check for conflicts} + for I := 1 to NumCmds do + with UK[I] do + if Length(Keys) <> 0 then + for J := 1 to NumCmds do + if (J <> I) and (Length(UK[J].Keys) <> 0) then + if Pos(UK[J].Keys, Keys) = 1 then begin + UK[I].Conflict := True; + UK[J].Conflict := True; + ConflictsFound := True; + end; + end; + +end. diff --git a/src/wc_sdk/tpdefine.inc b/src/wc_sdk/tpdefine.inc new file mode 100644 index 0000000..8b358bd --- /dev/null +++ b/src/wc_sdk/tpdefine.inc @@ -0,0 +1,130 @@ +{*********************************************************} +{* TPDEFINE.INC *} +{* Assorted conditional compilation directives *} +{*********************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Portions Copyright (c) Sunny Hill Software 1995, 1986 + * and used under license to TurboPower Software + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{This directive determines whether or not TPCRT is compiled in such a way as + to coexist peacefully with the standard Turbo Pascal CRT unit.} + +{.$DEFINE UseCrt} + +{This directive enables mouse support in several of the units, as well as in + some of the demo programs} + +{$DEFINE UseMouse} + +{The following define controls whether items within a menu system can + be temporarily disabled and re-enabled, and whether menus can be shadowed. + Defining Tpro5Menu will break (in a small way) menu systems defined with + Turbo Professional 4.0. The extent of the problem is limited to the color + arrays defined for each menu system -- the new color array requires two + additional items.} + +{$DEFINE Tpro5Menu} + +{If FourByteDates is defined, dates in TPDATE are stored as longints, giving a +range of 01/01/1600-12/31/3999. If it isn't defined, dates are stored as +words, giving a range of 01/01/1900-12/31/2078. WARNING! Between version 5.08 +and 5.09, we corrected a bug in TPDATE that affected date calculations when +FourByteDates was NOT defined. If you have been using word-sized dates with a +version of Turbo Professional prior to 5.09, please be sure to read the +discussion of this problem in the READ.ME file.} + +{$DEFINE FourByteDates} + +{Disable the following define if you never need to display directories (using + TPDIR) with file size, date and time. Doing so reduces the final application + size by up to 3200 bytes.} + +{$DEFINE AllowDateTime} + +{The following directive enables numeric (right-to-left) editor in TPENTRY} + +{.$DEFINE IncludeNumeric} + +{The following directive enables multiple choice fields in TPENTRY} + +{.$DEFINE IncludeChoice} + +{The following directive enables support for BCD reals in TPENTRY} + +{.$DEFINE UseBCD} + +{Deactivate the following define if the caller of TPSORT needs to perform + heap allocation or deallocation while the sort is in progress, that is, + within the user-defined procedures of the sort. For large sorts with + element size exceeding 4 bytes, FastDispose makes a significant difference + in the speed of heap deallocation when the sort is finished.} + +{$DEFINE FastDispose} + +{if the following directive is defined, TPTSR tries to thwart SideKick} + +{$DEFINE ThwartSideKick} + +{Deactivate the following define if exploding windows are not desired, + in order to save up to 2200 bytes of code space.} + +{.$DEFINE ExplodingWindows} + +{Deactivate the following define if shadowed windows are not desired, + in order to save up to 2000 bytes of code space.} + +{.$DEFINE ShadowedWindows} + +{Activate the following define if scrollable data entry screens are desired} + +{.$DEFINE TpEntryScrolls} + +{Activate the following define to allow unpickable items in TPPICK} + +{.$DEFINE PickItemDisable} + +{Activate the following define to allow alternate orientations in TPPICK} + +{.$DEFINE EnablePickOrientations} + +{The following define controls how various TPRO units react to the heap + changes of TP6 and later. There's no need for you to modify it.} + + {$IFDEF Ver60} + {$DEFINE Heap6} + {$ENDIF} + + {$IFDEF Ver70} + {$DEFINE Heap6} + {$I-,P-,T-,Q-} + {$ENDIF} + + {$IFDEF Ver80} + {$DEFINE Heap6} + {$I-,P-,T-,Q-} + {$ENDIF} diff --git a/src/wc_sdk/tvbrows.pas b/src/wc_sdk/tvbrows.pas new file mode 100644 index 0000000..91e8e18 --- /dev/null +++ b/src/wc_sdk/tvbrows.pas @@ -0,0 +1,1725 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +Unit TVBRows; + +{$I brdefopt.inc} + +Interface + +Uses + Objects, + Drivers, + Views, +{$IFDEF BrUseIsam} + Filer, {!!.TP} +{$ENDIF} +{$IFDEF BrUseShell} + OOPShell, +{$ENDIF} + LowBrows, + MedBrows, + HiBrows; + + +Const + CBrowserView = #29#27#28; + CBInterior = #2#6#7; + +Type + PBrowserScrollbar = ^TBrowserScrollBar; + LowWinBrowserPtr = ^LowWinBrowser; + PBrowserWindow = ^TBrowserWindow; + PBrowserView = ^TBrowserView; + + TBrowserScrollBar = Object ( TScrollBar ) + Function ScrollStep ( Part: Integer ): Integer; Virtual; + End; + + LowWinBrowser = Object ( BRHBrowser ) + Owner : PBrowserView; + + Constructor Init ( AOwner : PBrowserView; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + ALKey, + AHKey : GenKeyStr; + ASaveStat : Boolean; + Var ADatS; + AIsVarRec : Boolean ); + + Destructor Done; Virtual; + + Function PreCompletePage : Integer; Virtual; + + Function PostCompletePage : Integer; Virtual; + + Function BuildRow ( Var RR : RowRec ) : Integer; Virtual; + + Function PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; Virtual; + + Procedure ShowErrorOccured ( Class : Integer ); Virtual; + + End; + + TBrowserView = Object ( TView ) + PBrowser : LowWinBrowserPtr; + PHScrollBar, + PVScrollBar : PBrowserScrollBar; + + lwFullPage, + lwFirstRow, + lwMaxHorizOfs, + lwVertScale : Word; + lwHorizOfs : Integer; + + lwHeader, + lwFooter : BRLRowEltString; + +{$IFDEF BrUseIsam} + Constructor Init( Var Bounds : TRect; + PHS, PVS : PBrowserScrollBar; + AFileBlockPtr : IsamFileBlockPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + Var ADatS; + AIsVarRec : Boolean ); +{$ENDIF} +{$IFDEF BrUseShell} + Constructor Init( Var Bounds : TRect; + PHS, PVS : PBrowserScrollBar; + ADrvPtr : IFDriverPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString ); +{$ENDIF} + + Destructor Done; Virtual; + + Function PreCompletePage : Integer; Virtual; + Function PostCompletePage : Integer; Virtual; + + Function GetPalette: PPalette; Virtual; + + Procedure HandleEvent(var Event: TEvent); Virtual; + + Procedure Draw; Virtual; + + Procedure ChangeBounds ( Var Bounds : TRect ); Virtual; + + Procedure DisplayRow ( I : Integer; + Inverse : Boolean ); Virtual; + + Procedure SetAndUpdateBrowserScreen ( NewKeyStr : GenKeyStr; + NewRef : LongInt ); + + {--The following functions must be overwritten in descending objects} + Function BuildRow ( Var RR : RowRec ) : Integer; Virtual; + + {--The following routines may be overwritten in descending objects} + Function PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; Virtual; + + Procedure ShowErrorOccured ( Class : Integer ); Virtual; + + {--The following routines may be called from outside} + Procedure SetHeaderFooter ( AHeader, + AFooter : BRLRowEltString ); + + + Procedure SetLowHighKey ( ALowKey, AHighKey : GenKeyStr ); + + Procedure UpdateBrowserScreen; + Function GetThisRec ( Var RR : RowRec ) : Integer; + Function GetCurrentRec ( Var Match : Boolean ) : Integer; {mod !!.03} + Function GetCurrentKeyNr : Word; + Function GetCurrentKeyStr : String; + Function GetCurrentDatRef : LongInt; + Procedure SetKeyNr ( Value : Word ); + Function GetBrowseStatus : Boolean; Virtual; + Function BuildBrowScreenRow ( Var RR : RowRec ) : Integer; + + Private + {--The following routines are internal use only} + Function lwAdjustHorizOfs ( Delta : Integer) : Integer; + Procedure lwUpdateVertScrollBar; + Procedure lwUpdateHorzScrollBar; + Procedure lwReinit; + Procedure lwLineDown; + Procedure lwLineUp; + Procedure lwPageDown; + Procedure lwPageUp; + Procedure lwFirstPage; + Procedure lwLastPage; + Procedure lwMoveToRelPos ( Pos : Word ); + Procedure lwLineRight; + Procedure lwLineLeft; + Procedure lwPageRight; + Procedure lwPageLeft; + Procedure lwLeftHome; + Procedure lwRightHome; + Procedure lwMoveToHorizPos ( Pos : Word ); + Procedure lwMouseClicked ( Var Event : TEvent ); + End; + + + PBInterior = ^TBInterior; + TBInterior = Object ( TBrowserView ) + +{$IFDEF BrUseIsam} + Constructor Init( Var Bounds : TRect; + PHS, PVS : PBrowserScrollBar; + AFileBlockPtr : IsamFileBlockPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + Var ADatS; + AIsVarRec : Boolean ); +{$ENDIF} +{$IFDEF BrUseShell} + Constructor Init( Var Bounds : TRect; + PHS, PVS : PBrowserScrollBar; + ADrvPtr : IFDriverPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString ); +{$ENDIF} + + Destructor Done; Virtual; + + Function GetPalette: PPalette; Virtual; + + {--The following functions may be overwritten in descending objects} + Function PreCompletePage : Integer; Virtual; + Function PostCompletePage : Integer; Virtual; + + {--The following functions must be overwritten in descending objects} + Function BuildRow ( Var RR : RowRec ) : Integer; Virtual; + + {--The following routines may be overwritten in descending objects} + Function PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; Virtual; + + Procedure ShowErrorOccured ( Class : Integer ); Virtual; + + End; + + + + TBrowserWindow = Object ( TWindow ) + PInterior : PBrowserView; + {$IFDEF BRUseIsam} + Constructor Init ( var Bounds : TRect; + ATitle : TTitleStr; + ANumber : Integer; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + Var ADatS; + AIsVarRec : Boolean ); + +{$ENDIF} + +{$IFDEF BRUseShell} + Constructor Init ( Var Bounds : TRect; + ATitle : TTitleStr; + ANumber : Integer; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString ); +{$ENDIF} + + Destructor Done; Virtual; + + Function MakeBrowserScrollBar ( AOptions: Word ): PBrowserScrollBar; + + Procedure MakeInterior ( Bounds: TRect; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + Var ADatS; + AIsVarRec : Boolean; + AIsIsam : Boolean ); + + {--The following functions may be overwritten in descending objects} + Function PreCompletePage : Integer; Virtual; + Function PostCompletePage : Integer; Virtual; + + {--The following functions must be overwritten in descending objects} + Function BuildRow ( Var RR : RowRec ) : Integer; Virtual; + + {--The following routines may be overwritten in descending objects} + Function PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; Virtual; + + Procedure ShowErrorOccured ( Class : Integer ); Virtual; + + {--The following routines may be called from outside} + Procedure SetHeaderFooter ( AHeader, + AFooter : BRLRowEltString ); + + + Procedure SetAndUpdateBrowserScreen ( NewKeyStr : GenKeyStr; + NewRef : LongInt ); + Procedure UpdateBrowserScreen; + Function GetThisRec ( Var RR : RowRec ) : Integer; + Function GetCurrentRec ( Var Match : Boolean ) : Integer; {mod !!.03} + Function GetCurrentKeyNr : Word; + Function GetCurrentKeyStr : String; + Function GetCurrentDatRef : LongInt; + Procedure SetKeyNr ( Value : Word ); + Function GetBrowseStatus : Boolean; Virtual; + Function BuildBrowScreenRow ( Var RR : RowRec ) : Integer; + Procedure SetLowHighKey ( ALowKey, AHighKey : GenKeyStr ); + End; + +Implementation + + Const + VertScrollScale = 63; + +(**************************************************************************) + + Function TBrowserScrollBar.ScrollStep ( Part: Integer ): Integer; + + Begin + ScrollStep := 0; + Case Part of + sbLeftArrow : + Begin + If Message ( Owner, evKeyDown, kbLeft, @Self ) = Nil Then; + End; + sbRightArrow : + Begin + If Message ( Owner, evKeyDown, kbRight, @Self ) = Nil Then; + End; + sbPageLeft : + Begin + If Message ( Owner, evKeyDown, kbCtrlLeft, @Self ) = Nil Then; + End; + sbPageRight : + Begin + If Message ( Owner, evKeyDown, kbCtrlRight, @Self ) = Nil Then; + End; + sbUpArrow : + Begin + If Message ( Owner, evKeyDown, kbUp, @Self ) = Nil Then; + End; + sbDownArrow : + Begin + If Message ( Owner, evKeyDown, kbDown, @Self ) = Nil Then; + End; + sbPageUp : + Begin + If Message ( Owner, evKeyDown, kbPgUp, @Self ) = Nil Then; + End; + sbPageDown : + Begin + If Message ( Owner, evKeyDown, kbPgDn, @Self ) = Nil Then; + End; + End; + End; + + + Constructor LowWinBrowser.Init + ( AOwner : PBrowserView; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + ALKey, + AHKey : GenKeyStr; + ASaveStat : Boolean; + Var ADatS; + AIsVarRec : Boolean ); + + Begin + Owner := AOwner; + If Not BRHBrowser.Init ( ADrvOrFileBlockPtr, ANumberOfEltsPerRow, + ANumberOfRows, ALKey, AHKey, ASaveStat, ADatS, AIsVarRec ) Then Fail; + End; + + + Destructor LowWinBrowser.Done; + + Begin + BRHBrowser.Done; + Owner := Nil; + End; + + + Function LowWinBrowser.PreCompletePage : Integer; + + Begin + PreCompletePage := Owner^.PreCompletePage; + End; + + + Function LowWinBrowser.PostCompletePage : Integer; + + Begin + PostCompletePage := Owner^.PostCompletePage; + End; + + + Function LowWinBrowser.BuildRow ( Var RR : RowRec ) : Integer; + + Begin + BuildRow := Owner^.BuildRow ( RR ); + End; + + + Function LowWinBrowser.PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; + + Begin + PerFormFilter := Owner^.PerformFilter ( RR, UseIt ); + End; + + + Procedure LowWinBrowser.ShowErrorOccured ( Class : Integer ); + + Begin + Owner^.ShowErrorOccured ( Class ); + End; + +{$IFDEF BRUseIsam} + Constructor TBrowserView.Init( Var Bounds : TRect; + PHS, PVS : PBrowserScrollBar; + AFileBlockPtr : IsamFileBlockPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + Var ADatS; + AIsVarRec : Boolean ); + + +{$ENDIF} +{$IFDEF BrUseShell} + Constructor TBrowserView.Init( Var Bounds : TRect; + PHS, PVS : PBrowserScrollBar; + ADrvPtr : IFDriverPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString ); + +Var + Dummy : Pointer; +{$ENDIF} + + Var + PLW : LowWinBrowserPtr; + + Begin + TView.Init( Bounds ); + PHScrollBar := PHS; + PVScrollBar := PVS; + Eventmask := evMouseDown + evMouseMove + + evKeyDown + evBroadcast + evCommand; + + lwHeader := AHeader; + lwFooter := AFooter; + + lwHorizOfs := 0; + +{$IFDEF BrUseIsam} + New ( PLW, Init ( @Self, AFileBlockPtr, ANumberOfEltsPerRow, + ANumberOfRows, ALKey, AHKey, True, ADatS, AIsVarRec ) ); +{$ENDIF} + +{$IFDEF BrUseShell} + Dummy := Nil; + New ( PLW, Init ( @Self, ADrvPtr, ANumberOfEltsPerRow, + ANumberOfRows, ALKey, AHKey, False, Dummy, False ) ); +{$ENDIF} + If PLW = Nil Then Fail; + + PBrowser := PLW; + PBrowser^.KeyNr := AKeyNr; + + lwReinit; + lwVertScale := VertScrollScale; + Options := Options or ofSelectable; + + If PHScrollBar <> Nil Then + PHScrollBar^.SetParams ( 0, 0, lwMaxHorizOfs, 10, 1 ); + If PVScrollBar <> Nil Then + PVScrollBar^.SetParams ( 0, 0, lwVertScale, 10, 1 ); + + PBrowser^.SetNrOfRows ( lwFullPage ); + End; + + + Destructor TBrowserView.Done; + + Begin + If PBrowser <> Nil Then Dispose ( PBrowser, Done ); + TView.Done; + End; + + + Function TBrowserView.PreCompletePage : Integer; + + Begin + PreCompletePage := NoError; + End; + + Function TBrowserView.PostCompletePage : Integer; + + Begin + PostCompletePage := NoError; + End; + + Function TBrowserView.GetPalette: PPalette; + + Const + P: String[Length(CBrowserView)] = CBrowserView; + + Begin + GetPalette := @P; + End; + + + Procedure TBrowserView.DisplayRow ( I : Integer; + Inverse : Boolean); + Var + S : String; + + Procedure WriteStringOut ( S : String; LineNr : Word; Color : Byte ); + + Var + Y : Word; + S1 : String; + + Begin + S1 := S; + FillChar ( S1, 255 , 32 ); + S1 := Copy ( S, Succ ( lwHorizOfs ), 255); + S1 [0] := #255; + Y := ( LineNr + lwFirstRow - 2 ); + WriteStr ( 0, Y, S1, Color ); + End; + + + Begin + If I = 1 Then Begin + If ( lwHeader <> '' ) Or ( lwFooter <> '' ) Then Begin + If lwHeader <> '' Then Begin + WriteStringOut ( lwHeader, 0, 1 ); + End; + If lwFooter <> '' Then Begin + WriteStringOut ( lwFooter, Succ ( lwFullPage ), 1 ); + End; + End; + End; + + With PBrowser^, BSAPtr^[I]^ Do Begin + S := Row; + End; + If Inverse Then + WriteStringOut ( S, I, 3 ) + Else + WriteStringOut ( S, I, 2 ); + End; + + + Procedure TBrowserView.SetAndUpdateBrowserScreen ( NewKeyStr : GenKeyStr; + NewRef : LongInt ); + + Begin + With PBrowser^ Do Begin + HBuildNewPage ( KeyNr, NewKeyStr, NewRef, GetCurRow, NrOfRows ); + DrawView; + If StatusOK Then lwUpdateVertScrollBar; + End; + End; + + + Function TBrowserView.lwAdjustHorizOfs ( Delta : Integer ) : Integer; + + Var + Offset : LongInt; + + Begin + Offset := LongInt (lwHorizOfs) + Delta; + If Offset < 0 Then Begin + Offset := 0; + End Else Begin + If OffSet > lwMaxHorizOfs Then Begin + Offset := lwMaxHorizOfs; + End; + End; + lwAdjustHorizOfs := Offset; + End; + + + Procedure TBrowserView.lwUpdateVertScrollBar; + {-Update vertical scroll bar} + + Var + RelPos : Word; + Dummy : Integer; + + Begin + If PVScrollBar = Nil Then Exit; + With PBrowser^ Do Begin + HGetApprRelPos ( RelPos, lwVertScale, GetCurrentKeyStr, + GetCurrentDatRef ); + If Not StatusOK Then RelPos := 0; + PVScrollBar^.Value := RelPos; + PVScrollBar^.DrawView; + If Message ( Self.Owner, evBroadcast, cmScrollBarChanged, @Self ) = Nil Then; + End; + End; + + + Procedure TBrowserView.lwUpdateHorzScrollBar; + {-Update horizontal scroll bar} + + Var + Dummy : Integer; + + Begin + If PHScrollBar = Nil Then Exit; + If lwMaxHorizOfs > 0 Then Begin + PHScrollBar^.Value := lwHorizOfs; + PHScrollBar^.DrawView; + If Message ( Self.Owner, evBroadcast, cmScrollBarChanged, @Self ) = Nil Then; + End; + End; + + + Procedure TBrowserView.lwReinit; + {-Initialize variables that can change if window is resized} + + Var + R : TRect; + MaxWidth, + Width : Word; + + Begin + GetExtent ( R ); + + {--Vertical stuff in rows} + lwFullPage := ( R.B.Y - R.A.Y ); + lwFirstRow := 1; + If lwHeader <> '' Then Begin + Dec ( lwFullPage ); + Inc ( lwFirstRow ); + End; + If lwFooter <> '' Then Dec (lwFullPage); + + {--Horizontal stuff in pixels} + Width := R.B.X - R.A.X; + MaxWidth := MaxCols; + If Width > MaxWidth Then Begin + lwMaxHorizOfs := 0; + End Else Begin + lwMaxHorizOfs := MaxWidth - Width; + End; + + {--Final vertical stuff} + If lwMaxHorizOfs = 0 Then Begin + Inc ( lwFullPage ); + End; + If lwFullPage > $FFF0 Then lwFullPage := 1; + {-Holds functionality of this browser when resized below 1} + If PHScrollBar <> Nil Then + PHScrollBar^.SetParams ( 0, 0, lwMaxHorizOfs, 10, 1 ); + End; + + + Procedure TBrowserView.lwLineDown; + + Var + LRow : Word; + Moved : Word; + CR : Word; + R : TRect; + Update, + Dummy : Boolean; + TRR : RowRec; + + Begin + Update := True; + With PBrowser^ Do Begin + LRow := GetLastRow; {mod !!.03} + CR := GetCurRow; + If ( CR = LRow ) Or ( LRow = 0 ) Then Begin + HBuildNextPage ( 1, Moved, True, 0, Dummy ); + If StatusOK Then Begin + If OtherAction Then Begin + DrawView; + End Else Begin + If Moved = 1 Then Begin + If lwFullPage <> 1 Then Begin + If LRow = GetLastRow Then Begin {mod !!.03} + DrawView; + End Else Begin + SetCurRow ( Succ (CR) ); + DisplayRow ( LRow, False); + End; + End; + DisplayRow ( CR, True); + End Else Begin + Update := False; + End; + End; + End Else Begin + Update := False; + End; + End Else Begin + DisplayRow ( CR , False ); + SetCurRow ( Succ (CR) ); + DisplayRow ( GetCurRow, True ); + End; + End; + If Update Then lwUpdateVertScrollBar; + End; + + + Procedure TBrowserView.lwLineUp; + + Var + Moved : Word; + CR : Word; + R : TRect; + Update, + Dummy : Boolean; + TRR : RowRec; + + Begin + Update := True; + With PBrowser^Do Begin + CR := GetCurRow; + If CR = 1 Then Begin + HBuildPrevPage ( 1, Moved, True, 0, Dummy ); + If StatusOK Then Begin + If OtherAction Then Begin + DrawView; + End Else Begin + If Moved = 1 Then Begin + If lwFullPage <> 1 Then Begin + DrawView; + End; + DisplayRow ( 1, True); + End Else Begin + Update := False; + End; + End; + End Else Begin + Update := False; + End; + End Else Begin + DisplayRow ( CR , False ); + SetCurRow ( Pred (CR) ); + DisplayRow ( GetCurRow, True ); + End; + End; + If Update Then lwUpdateVertScrollBar; + End; + + + Procedure TBrowserView.lwPageDown; + + Var + BST : BrowScreenState; + Moved : Word; + Update, + Changed : Boolean; + + Begin + Update := False; + With PBrowser^ Do Begin + GetBrowScreenState ( BST ); + HBuildNextPage ( lwFullPage, Moved, True, 1, Changed ); + If StatusOK Then Begin + If OtherAction Or (Moved > 0) Or Changed + Or BrowScreenStateChanged ( BST ) Then Begin + DrawView; + Update := True; + End; + End; + End; + If Update Then lwUpdateVertScrollBar; + End; + + + Procedure TBrowserView.lwPageUp; + + Var + BST : BrowScreenState; + Moved : Word; + Update, + Changed : Boolean; + + Begin + Update := False; + With PBrowser^ Do Begin + GetBrowScreenState ( BST ); + HBuildPrevPage ( lwFullPage, Moved, True, 1, Changed ); + If StatusOK Then Begin + If OtherAction Or (Moved > 0) Or Changed + Or BrowScreenStateChanged ( BST ) Then Begin + DrawView; + Update := True; + End; + End; + End; + If Update Then lwUpdateVertScrollBar; + End; + + + Procedure TBrowserView.lwFirstPage; + + Var + BST : BrowScreenState; + Update, + Changed : Boolean; + + Begin + Update := False; + With PBrowser^ Do Begin + GetBrowScreenState ( BST ); + HBuildFirstPage ( Changed ); + If StatusOK Then Begin + If Changed Or BrowScreenStateChanged ( BST ) Then Begin + DrawView; + Update := True; + End; + End; + End; + If Update Then lwUpdateVertScrollBar; + End; + + + Procedure TBrowserView.lwLastPage; + + Var + BST : BrowScreenState; + Update, + Changed : Boolean; + + Begin + Update := False; + With PBrowser^ Do Begin + GetBrowScreenState ( BST ); + HBuildLastPage ( Changed ); + If StatusOK Then Begin + If Changed Or BrowScreenStateChanged ( BST ) Then Begin + DrawView; + Update := True; + End; + End; + End; + If Update Then lwUpdateVertScrollBar; + End; + + + Procedure TBrowserView.lwMoveToRelPos ( Pos : Word ); + + Var + Key : GenKeyStr; + Ref : LongInt; + + Begin + PBrowser^.HGetApprKeyAndRef ( Pos, lwVertScale, Key, Ref ); + SetAndUpdateBrowserScreen ( Key, Ref ); + End; + + + Procedure TBrowserView.lwLineRight; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := lwHorizOfs; + lwHorizOfs := lwAdjustHorizOfs ( 1 ); + If OldHOfs <> lwHorizOfs Then Begin + DrawView; + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserView.lwLineLeft; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := lwHorizOfs; + lwHorizOfs := lwAdjustHorizOfs ( -1 ); + If OldHOfs <> lwHorizOfs Then Begin + DrawView; + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserView.lwPageRight; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := lwHorizOfs; + lwHorizOfs := lwAdjustHorizOfs ( 10 ); + If OldHOfs <> lwHorizOfs Then Begin + DrawView; + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserView.lwPageLeft; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := lwHorizOfs; + lwHorizOfs := lwAdjustHorizOfs ( -10 ); + If OldHOfs <> lwHorizOfs Then Begin + DrawView; + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserView.lwLeftHome; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := lwHorizOfs; + lwHorizOfs := 0; + If OldHOfs <> lwHorizOfs Then Begin + DrawView; + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserView.lwRightHome; + + Var + OldHOfs : Integer; + + Begin + If PBrowser = Nil Then Exit; + OldHOfs := lwHorizOfs; + lwHorizOfs := lwMaxHorizOfs; + If OldHOfs <> lwHorizOfs Then Begin + DrawView; + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserView.lwMoveToHorizPos ( Pos : Word ); + + Var + OldHOfs : Integer; + + Begin + OldHOfs := lwHorizOfs; + lwHorizOfs := Pos; + lwHorizOfs := lwAdjustHorizOfs ( 0 ); + If OldHOfs <> lwHorizOfs Then Begin + DrawView; + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserView.lwMouseClicked ( Var Event : TEvent ); + + Var + Y : Word; + OldCurrow : Integer; + Point : TPoint; + + Begin + If PBrowser = Nil Then Exit; + MakeLocal ( Event.Where, Point ); + Y := Point.Y; + OldCurrow := PBrowser^.GetCurrow; + If OldCurRow <> 0 Then Begin + PBrowser^.SetCurRow ( Y + 2 - lwFirstRow ); + If ( OldCurRow <> PBrowser^.GetCurRow ) And + ( PBrowser^.GetCurRow <> 0 ) Then Begin + DisplayRow ( OldCurRow, False ); + DisplayRow ( PBrowser^.GetCurRow, True ); + lwUpDateVertScrollBar; + End; + End; + End; + + + Procedure TBrowserView.ChangeBounds ( Var Bounds : TRect ); + + Var + R : TRect; + D : Integer; + Changed : Boolean; + + Begin + TView.GetBounds ( R ); + TView.ChangeBounds ( Bounds ); + D :=(Bounds.B.Y - Bounds.A.Y) - (R.B.Y - R.A.Y); + IF D <> 0 Then Begin + lwReInit; + If D > 0 Then PBrowser^.HExpandPage ( lwFullPage ) Else + If D < 0 Then PBrowser^.HShrinkPage ( lwFullpage ); + DrawView; + End; + End; + + + Procedure TBrowserView.Draw; + + Var + I : Word; + CR : Word; + + Begin + If PBrowser = Nil Then Begin + TView.Draw; + Exit; + End; + CR := PBrowser^.GetCurRow; + For I := 1 To lwFullPage Do Begin + DisplayRow ( I, I = CR); + End; + End; + + + Procedure TBrowserView.HandleEvent ( Var Event: TEvent ); + + Begin + TView.HandleEvent ( Event ); + If State and sfSelected <> 0 Then Begin + Case Event.What Of + evBroadCast : + Begin + If Event.Command = cmScrollBarChanged Then Begin + If Event.InfoPtr = PHScrollbar Then + lwMoveToHorizPos ( PHScrollbar^.Value ) + Else If Event.InfoPtr = PVScrollbar Then + lwMoveToRelPos ( PVScrollbar^.Value ) + Else + Exit; + End Else + Exit; + End; + + evMouseDown, evMouseMove: + Begin + If ( State And sfActive <> 0 ) And + ( Event.Buttons = 1 ) Then Begin + lwMouseClicked ( Event ); + If Event.Double Then + If Message(Owner, evBroadcast, cmListItemSelected, @Self) = Nil Then; + End Else + Exit; + End; + evKeyDown: + Begin + Case Event.KeyCode Of + kbUp: + Begin + lwLineUp; + End; + kbDown: + Begin + lwLineDown; + End; + kbRight: + Begin + lwLineRight; + End; + kbLeft: + Begin + lwLineLeft; + End; + kbCtrlRight: + Begin + lwPageRight; + End; + kbCtrlLeft: + Begin + lwPageLeft; + End; + kbPgUp: + Begin + lwPageUp; + End; + kbPgDn: + Begin + lwPageDown; + End; + kbCtrlPgDn: + Begin + lwLastPage; + End; + kbCtrlPgUp: + Begin + lwFirstPage; + End; + kbHome: + Begin + lwLeftHome; + End; + kbEnd: + Begin + lwRightHome; + End; + Else + Exit; + End; + End + Else + Exit + End; + ClearEvent ( Event ); + End Else Begin + If Options And ofSelectable <> 0 Then Begin + If (Event.Command = cmScrollBarClicked) And + ((Event.InfoPtr = PHScrollBar) Or + (Event.InfoPtr = PVScrollBar)) Then Begin + Select; + End; + End; + End; + End; + + Function TBrowserView.BuildRow ( Var RR : RowRec ) : Integer; + + Begin + RunError ( 211 ); + End; + + + Function TBrowserView.PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; + + Begin + UseIt := True; + PerformFilter := NoError; + End; + + + Procedure TBrowserView.ShowErrorOccured ( Class : Integer ); + + Begin + End; + + + Procedure TBrowserView.SetHeaderFooter ( AHeader, + AFooter : BRLRowEltString ); + + Var + OldNrOfRows : Word; + + Begin + lwHeader := AHeader; + lwFooter := AFooter; + If PBrowser = Nil Then Exit; + OldNrOfRows := lwFullPage; + lwReinit; + With PBrowser^ Do Begin + If OldNrOfRows > lwFullPage Then Begin + HShrinkPage ( lwFullPage ); + End Else Begin + If OldNrOfRows < lwFullPage Then Begin + HExpandPage ( lwFullPage ); + End; + End; + DrawView; + End; + End; + + Procedure TBrowserView.SetLowHighKey ( ALowKey, AHighKey : GenKeyStr ); + + Begin + With PBrowser^Do Begin + LowKey := ALowKey; + HighKey := AHighKey; + End; + End; + + + Procedure TBrowserView.UpdateBrowserScreen; + + Var + Changed : Boolean; + + Begin + With PBrowser^ Do Begin + HBuildThisPage ( Changed ); + If Changed Then Begin + DrawView; + If StatusOK Then lwUpdateVertScrollBar; + End; + End; + End; + + + Function TBrowserView.GetCurrentRec ( Var Match : Boolean ) : + Integer; {mod !!.03} + + Var + Result : Integer; + + Begin + With PBrowser^ Do Begin + Result := GetRowMatchingRec ( BSAPtr^[GetCurRow]^, True, True, + Match ); + End; + GetCurrentRec := Result; + End; + + + Function TBrowserView.GetThisRec ( Var RR : RowRec ) : Integer; + + Begin + GetThisRec := PBrowser^.BRGetRec ( RR, False, False ); + End; + + + Function TBrowserView.GetCurrentKeyNr : Word; + + Begin + GetCurrentKeyNr := PBrowser^.KeyNr; + End; + + + Function TBrowserView.GetCurrentKeyStr : String; + + Begin + GetCurrentKeyStr := PBrowser^.GetCurrentKeyStr; + End; + + + Function TBrowserView.GetCurrentDatRef : LongInt; + + Begin + GetCurrentDatRef := PBrowser^.GetCurrentDatRef; + End; + + + Procedure TBrowserView.SetKeyNr ( Value : Word ); + + Begin + PBrowser^.KeyNr := Value; + End; + + Function TBrowserView.GetBrowseStatus : Boolean; + Begin + GetBrowseStatus := PBrowser^.StatusOK; + End; + + Function TBrowserView.BuildBrowScreenRow ( Var RR : RowRec ) : Integer; + + Begin + BuildBrowScreenRow := PBrowser^.BuildBrowScreenRow ( RR ); + End; + + +(****************************************************************************) +{$IFDEF BrUseIsam} + Constructor TBInterior.Init( Var Bounds : TRect; + PHS, PVS : PBrowserScrollBar; + AFileBlockPtr : IsamFileBlockPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + Var ADatS; + AIsVarRec : Boolean ); +{$ENDIF} +{$IFDEF BrUseShell} + Constructor TBInterior.Init( Var Bounds : TRect; + PHS, PVS : PBrowserScrollBar; + ADrvPtr : IFDriverPtr; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString ); +{$ENDIF} + + Begin +{$IFDEF BrUseIsam} + If Not TBrowserView.Init ( Bounds, PHS, PVS, + AFileBlockPtr, + ANumberOfEltsPerRow, + ANumberOfRows, + AKeyNr, ALKey, AHKey, + AHeader, AFooter, + ADatS, AIsVarRec ) Then Begin +{$ENDIF} +{$IFDEF BrUseShell} + If Not TBrowserView.Init ( Bounds, PHS, PVS, + ADrvPtr, + ANumberOfEltsPerRow, + ANumberOfRows, + AKeyNr, ALKey, AHKey, + AHeader, AFooter ) Then Begin +{$ENDIF} + + Fail; + End; + End; + + Destructor TBInterior.Done; + Begin + TBrowserView.Done; + End; + + + Function TBInterior.PreCompletePage : Integer; + + Begin + PreCompletePage := PBrowserWindow ( Owner )^.PreCompletePage; + End; + + + Function TBInterior.PostCompletePage : Integer; + + Begin + PostCompletePage := PBrowserWindow ( Owner )^.PostCompletePage; + End; + + + Function TBInterior.GetPalette: PPalette; + + Const + P: String[Length(CBInterior)] = CBInterior; + + Begin + GetPalette := @P; + End; + + Function TBInterior.BuildRow ( Var RR : RowRec ) : Integer; + + Begin + BuildRow := PBrowserWindow ( Owner )^.BuildRow ( RR ); + End; + + Function TBInterior.PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; + + Begin + PerformFilter := PBrowserWindow ( Owner )^.PerformFilter ( RR, UseIt ); + End; + + Procedure TBInterior.ShowErrorOccured ( Class : Integer ); + Begin + PBrowserWindow ( Owner )^.ShowErrorOccured ( Class ); + End; + +(****************************************************************************) + + Function TBrowserWindow.MakeBrowserScrollBar ( AOptions: Word ): PBrowserScrollBar; + + Var + R: TRect; + S: PBrowserScrollBar; + + Begin + GetExtent ( R ); + If AOptions And sbVertical = 0 Then + R.Assign ( R.A.X + 2, R.B.Y-1, R.B.X-2, R.B.Y ) + Else + R.Assign ( R.B.X-1,R.A.Y+1,R.B.X,R.B.Y-1 ); + S := New ( PBrowserScrollBar, Init ( R ) ); + If S <> Nil Then Begin + If AOptions And sbHandleKeyboard <> 0 Then + S^.Options := S^.Options Or ofPostProcess; + End; + MakeBrowserScrollBar := S; + End; + + + Procedure TBrowserWindow.MakeInterior ( Bounds: TRect; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + Var ADatS; + AIsVarRec : Boolean; + AIsIsam : Boolean ); + + + Var + PVS, PHS : PBrowserScrollBar; + + Begin + PVS := MakeBrowserScrollBar ( sbVertical ); + If PVS = Nil Then Exit; + PHS := MakeBrowserScrollBar ( sbHorizontal ); + IF PHS = Nil Then Begin + Dispose ( PVS, Done ); + Exit; + End; + +{$IFDEF BrUseIsam} + PInterior := New ( PBInterior, Init ( Bounds, PHS, PVS, + IsamFileBlockPtr ( ADrvOrFileBlockPtr ), + ANumberOfEltsPerRow, + ANumberOfRows, + AKeyNr, + ALKey, + AHKey, + AHeader, + AFooter, + ADatS, + AIsVarRec )); +{$ENDIF} +{$IFDEF BrUseShell} + PInterior := New ( PBInterior, Init ( Bounds, PHS, PVS, + IFDriverPtr ( ADrvOrFileBlockPtr ), + ANumberOfEltsPerRow, + ANumberOfRows, + AKeyNr, + ALKey, + AHKey, + AHeader, + AFooter )); +{$ENDIF} + If PInterior <> Nil Then With PInterior^ Do Begin + GrowMode := gfGrowHiX + gfGrowHiY; + Options := Options or ofPostProcess; + Insert ( PInterior ); + End Else Begin + Dispose ( PVS, Done ); + Dispose ( PHS, Done ); + Exit; + End; + + Insert ( PVS ); + Insert ( PHS ); + End; + + Function TBrowserWindow.PreCompletePage : Integer; + + Begin + PreCompletePage := NoError; + End; + + Function TBrowserWindow.PostCompletePage : Integer; + + Begin + PostCompletePage := NoError; + End; + +{$IFDEF BRUseIsam} + Constructor TBrowserWindow.Init ( var Bounds : TRect; + ATitle : TTitleStr; + ANumber : Integer; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString; + Var ADatS; + AIsVarRec : Boolean ); + + Var + R : TRect; + + Begin + If Not TWindow.Init( Bounds, ATitle, ANumber ) Then Fail; + GetExtent ( R ); + R.Grow ( -1, -1 ); + + MakeInterior ( R, + ADrvOrFileBlockPtr, 1, ANumberOfRows, AKeyNr, ALKey, AHKey, AHeader, + AFooter, ADatS, AIsVarRec, True ); + If PInterior= Nil Then Begin + TWindow.Done; + Fail; + End; + End; +{$ENDIF} + + +{$IFDEF BRUseShell} + Constructor TBrowserWindow.Init + ( Var Bounds : TRect; + ATitle : TTitleStr; + ANumber : Integer; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + AHeader, + AFooter : BRLRowEltString ); + + Var + Dummy : Pointer; + R : TRect; + + Begin + Dummy := Nil; + If Not TWindow.Init( Bounds, ATitle, ANumber ) Then Fail; + GetExtent ( R ); + R.Grow ( -1, -1 ); + + MakeInterior ( R, + ADrvOrFileBlockPtr, 1, ANumberOfRows, AKeyNr, ALKey, AHKey, AHeader, + AFooter, Dummy, False, False ); + + If PInterior = Nil Then Begin + TWindow.Done; + Fail; + End; + End; +{$ENDIF} + + + Destructor TBrowserWindow.Done; + + Begin + If PInterior <> Nil Then Dispose ( PInterior, Done ); + TWindow.Done; + End; + + + Function TBrowserWindow.BuildRow ( Var RR : RowRec ) : Integer; + + Begin + RunError ( 211 ); + End; + + + Function TBrowserWindow.PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; + + Begin + UseIt := True; + PerformFilter := NoError; + End; + + + Procedure TBrowserWindow.ShowErrorOccured ( Class : Integer ); + + Begin + End; + + + Procedure TBrowserWindow.SetHeaderFooter ( AHeader, + AFooter : BRLRowEltString ); + + Var + OldNrOfRows : Word; + + Begin + If PInterior <> Nil Then With PInterior^ Do Begin + lwHeader := AHeader; + lwFooter := AFooter; + If PBrowser = Nil Then Exit; + OldNrOfRows := lwFullPage; + lwReinit; + With PBrowser^ Do Begin + If OldNrOfRows > lwFullPage Then Begin + HShrinkPage ( lwFullPage ); + End Else Begin + If OldNrOfRows < lwFullPage Then Begin + HExpandPage ( lwFullPage ); + End; + End; + DrawView; + End; + End; + End; + + Procedure TBrowserWindow.SetLowHighKey ( ALowKey, AHighKey : GenKeyStr ); + + Begin + If PInterior <> Nil Then + PInterior^.SetLowHighKey ( ALowKey, AHighKey ); + End; + + + Procedure TBrowserWindow.SetAndUpdateBrowserScreen ( NewKeyStr : GenKeyStr; + NewRef : LongInt ); + + Begin + If PInterior <> Nil Then + PInterior^.SetAndUpdateBrowserScreen ( NewKeyStr, NewRef ); + End; + + + Procedure TBrowserWindow.UpdateBrowserScreen; + + Var + Changed : Boolean; + + Begin + If PInterior <> Nil Then + PInterior^.UpdateBrowserScreen; + End; + + + Function TBrowserWindow.GetCurrentRec ( Var Match : Boolean ) : + Integer; {mod !!.03} + + Var + Result : Integer; + + Begin + GetCurrentRec := DialogError; {!!.05} + If PInterior <> Nil Then Begin + With PInterior^, PBrowser^ Do Begin + Result := GetRowMatchingRec ( BSAPtr^[GetCurRow]^, True, True, + Match ); + End; + GetCurrentRec := Result; + End; + End; + + + Function TBrowserWindow.GetThisRec ( Var RR : RowRec ) : Integer; + + Begin + GetThisRec := DialogError; {!!.05} + If PInterior <> Nil Then + GetThisRec := PInterior^.GetThisRec ( RR ); + End; + + + Function TBrowserWindow.GetCurrentKeyNr : Word; + + Begin + GetCurrentKeyNr := DialogError; {!!.05} + If PInterior <> Nil Then + GetCurrentKeyNr := PInterior^.PBrowser^.KeyNr; + End; + + + Function TBrowserWindow.GetCurrentKeyStr : String; + + Begin + GetCurrentKeyStr := ''; {!!.05} + If PInterior <> Nil Then + GetCurrentKeyStr := PInterior^.PBrowser^.GetCurrentKeyStr; + End; + + + Function TBrowserWindow.GetCurrentDatRef : LongInt; + + Begin + GetCurrentdatRef := 0; {!!.05} + If PInterior <> Nil Then + GetCurrentDatRef := PInterior^.PBrowser^.GetCurrentDatRef; + End; + + + Procedure TBrowserWindow.SetKeyNr ( Value : Word ); + + Begin + If PInterior <> Nil Then + PInterior^.PBrowser^.KeyNr := Value; + End; + + Function TBrowserWindow.GetBrowseStatus : Boolean; + Begin + GetBrowseStatus := False; {!!.05} + If PInterior <> Nil Then {!!.05} + GetBrowseStatus := PInterior^.GetBrowseStatus; + End; + + + Function TBrowserWindow.BuildBrowScreenRow ( Var RR : RowRec ) : Integer; + + Begin + BuildBrowScreenRow := DialogError; {!!.05} + If PInterior <> Nil Then {!!.05} + BuildBrowScreenRow := PInterior^.BuildBrowScreenRow ( RR ); + End; + +End. diff --git a/src/wc_sdk/vrcompat.pas b/src/wc_sdk/vrcompat.pas new file mode 100644 index 0000000..e0ed8a7 --- /dev/null +++ b/src/wc_sdk/vrcompat.pas @@ -0,0 +1,172 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} + {$I btdefine.inc} + {$F-,V-,B-,S-,I-,R-} + {$IFDEF CanSetOvrflowCheck} + {$Q-} + {$ENDIF} + +Unit VRCompat; + +Interface + +Uses + Filer, + VRec; + +var + VRecBufSize : Word absolute IsamVRecBufSize; + +type + IsamAccessMode = (Normal, InSpiteOfLock, ReadOnly); + + Function CreateVariableRecBuffer ( IFBPtr : IsamFileBlockPtr ) : BOOLEAN; + + Procedure ReleaseVariableRecBuffer; + + Function SetVariableRecBuffer ( Size : Word ) : Boolean; + + Procedure AddVariableRec ( IFBPtr : IsamFileBlockPtr; + Var RefNr : LongInt; + Var Source; + Len : Word); + + Procedure DeleteVariableRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt ); + + + Procedure PutVariableRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Source; + Len : Word; + Mode : IsamAccessMode ); + + Procedure GetVariableRecPart ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest; + Var Len : Word; + Mode : IsamAccessMode ); + + Procedure GetVariableRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest; + Var Len : Word; + Mode : IsamAccessMode ); + + Procedure GetVariableRecLength ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Len : Word ); + +(*Procedure GetVariableRecRebuilt ( Var F : IsamFile; + DatSLen : Word; + Var RefNr : LongInt; + OnlyLen : Boolean; + Var Dest; + Var Len : Word );*) {!!.50} + +Implementation + + Function CreateVariableRecBuffer ( IFBPtr : IsamFileBlockPtr ) : Boolean; + Begin + CreateVariableRecBuffer := BTCreateVariableRecBuffer ( IFBPtr ); + End; + + Procedure ReleaseVariableRecBuffer; + Begin + BTReleaseVariableRecBuffer; + End; + + Function SetVariableRecBuffer ( Size : Word ) : Boolean; + Begin + SetVariableRecBuffer := BTSetVariableRecBuffer ( Size ); + End; + + Procedure AddVariableRec ( IFBPtr : IsamFileBlockPtr; + Var RefNr : LongInt; + Var Source; + Len : Word); + Begin + BTAddVariableRec ( IFBPtr, RefNr, Source, Len ); + End; + + Procedure DeleteVariableRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt ); + Begin + BTDeleteVariableRec ( IFBPtr, RefNr ); + End; + + + Procedure PutVariableRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Source; + Len : Word; + Mode : IsamAccessMode ); + Begin + BTPutVariableRec ( IFBPtr, RefNr, Source, Len ); + End; + + Procedure GetVariableRecPart ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest; + Var Len : Word; + Mode : IsamAccessMode ); + Begin + BTGetVariableRecPart ( IFBPtr, RefNr, Dest, Len ); + End; + + Procedure GetVariableRec ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Dest; + Var Len : Word; + Mode : IsamAccessMode ); + Begin + BTGetVariableRec ( IFBPtr, RefNr, Dest, Len ); + End; + + Procedure GetVariableRecLength ( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + Var Len : Word ); + Begin + BTGetVariableRecLength ( IFBPtr, RefNr, Len ); + End; + +(*Procedure GetVariableRecRebuilt ( Var F : IsamFile; + DatSLen : Word; + Var RefNr : LongInt; + OnlyLen : Boolean; + Var Dest; + Var Len : Word ); + Begin + BTGetVariableRecRebuilt ( F, DatSLen, RefNr, OnlyLen, Dest, Len, $FFFF ); + End; +*) {!!.50} + +Begin + VRecBufSize := 0; +End. diff --git a/src/wc_sdk/vrebuild.pas b/src/wc_sdk/vrebuild.pas new file mode 100644 index 0000000..8d593af --- /dev/null +++ b/src/wc_sdk/vrebuild.pas @@ -0,0 +1,83 @@ +{********************************************************************} +{* VREBUILD.PAS - rebuild variable-length fileblock *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + +Unit + VReBuild; + +Interface + +Uses + BTBase, + BTIsBase, + Filer, {!!.TP} + Restruct, + Reindex; + + Procedure RebuildVFileBlock ( FBlName : IsamFileBlockName; + DatSLen : LongInt; + NumberOfKeys : Word; + IID : IsamIndDescr; + BuildKeyFunc : FuncBuildKey ); + {-Rebuilds a variable record length fileblocks data and index structure} + + +Implementation + + Procedure RebuildVFileBlock ( FBlName : IsamFileBlockName; + DatSLen : LongInt; + NumberOfKeys : Word; + IID : IsamIndDescr; + BuildKeyFunc : FuncBuildKey ); + + Var + Dummy : Boolean; + + Begin + RestructFileBlock ( FBlName, DatSLen, DatSLen, True, 0, + ChangeDatSNoChange, BTNoCharConvert, Nil ); + If Not IsamOK Then Exit; + If NumberOfKeys > 0 Then Begin + ReIndexFileBlock ( FBlName, NumberOfKeys, IID, True, + BuildKeyFunc, True, Dummy, + BTNoCharConvert, Nil ); + End; + End; + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/vrec.pas b/src/wc_sdk/vrec.pas new file mode 100644 index 0000000..569e53c --- /dev/null +++ b/src/wc_sdk/vrec.pas @@ -0,0 +1,585 @@ +{********************************************************************} +{* VREC.PAS - B-Tree Filer variable-length record support *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + +Unit + VRec; + +interface + +uses + BTBase, + BTIsBase, + {$IFDEF UsingDelphi} + SysUtils, + {$ENDIF} + Filer; {!!.TP} + +const + MaxVariableRecLength = $FFF0; +{--Internal use only} {!!.50mov} + MaxVariableRecLengthM1 = MaxVariableRecLength - 1; {!!.50mov} + +{--Internal use only} {!!.50mov} +type {!!.50mov} + IsamVRecBuf = Array [0..MaxVariableRecLengthM1] of Byte; {!!.50mov} + PIsamVRecBuf = ^IsamVRecBuf; {!!.50} + +{--Internal use only} {!!.50mov} +var + IVRBPtr : PIsamVRecBuf; {!!.50mov} + IsamVRecBufSize : Word; + + +function BTCreateVariableRecBuffer(IFBPtr : IsamFileBlockPtr) : Boolean; + {-Create a variable record buffer for the fileblock with the greatest + data record length of all variable record fileblocks} + +procedure BTReleaseVariableRecBuffer; + {-Release the variable record buffer} + +function BTSetVariableRecBuffer(Size : Word) : Boolean; + {-Create a variable record buffer with Size bytes as an alternative to + CreateVariableRecBuffer} + +procedure BTAddVariableRec(IFBPtr : IsamFileBlockPtr; + var RefNr : LongInt; + var Source; + Len : Word); + {-Adds a record with variable length} + +procedure BTDeleteVariableRec(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt); + {-Deletes a record with variable length} + +procedure BTPutVariableRec(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Source; + Len : Word); + {-Puts a record with variable length to its old place} + +procedure BTGetVariableRecPart(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Dest; + var Len : Word); + {-Reads at maximum Len bytes of a variable record} + +procedure BTGetVariableRec(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Dest; + var Len : Word); + {-Reads a variable record and returns the read number of bytes in Len} + +procedure BTGetVRecPartReadOnly(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Dest; + var Len : Word); + {-Reads a variable record and returns the read number of bytes in Len; + needs either a record lock or another lock, else will do a readlock} + +procedure BTGetVRecReadOnly(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Dest; + var Len : Word); + {-Reads at maximum Len bytes of a variable record; + needs either a record lock or another lock, else will do a readlock} + +procedure BTGetVariableRecLength(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Len : Word); + {-Gets the length of a variable record and returns it in Len} + + +function BTAdjustVariableRecBuffer(Size : Word) : Boolean; {!!.50} + {-Increases the variable record buffer if necessary} + + {!!.50del BTGetVariableRecRebuilt} + + +implementation + +{-Types, constants and variables moved to the interface} {!!.50} + + +function CreateVariableRecBuffer(S : Word) : Boolean; {!!.52 rewritten} +begin + if not IsamGetMem(IVRBPtr, S) then + CreateVariableRecBuffer := False + else begin + IsamVRecBufSize := S; + CreateVariableRecBuffer := True; + end; +end; + + +function CreateVariableRecBufferIFB(IFBPtr : IsamFileBlockPtr) : Boolean; +begin + CreateVariableRecBufferIFB := CreateVariableRecBuffer + (Word (ILI (IFBPtr^.DIDPtr^[0]^.LenRec).Lo)); +end; + + +function BTCreateVariableRecBuffer(IFBPtr : IsamFileBlockPtr) : Boolean; +begin + IsamEntryCode(IFBPtr, NoOptions); {!!.50} + if IsamOK then begin {!!.50} + BTCreateVariableRecBuffer := CreateVariableRecBufferIFB(IFBPtr); + end + else begin {!!.50} + BTCreateVariableRecBuffer := False; {!!.50} + end; {!!.50} + IsamExitCode(IFBPtr); {!!.50} +end; + + +procedure ReleaseVariableRecBuffer; +begin + if IsamVRecBufSize <> 0 then begin + FreeMem(IVRBPtr, IsamVRecBufSize); + IsamVRecBufSize := 0; + end; +end; + + +procedure BTReleaseVariableRecBuffer; +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); {!!.50} + if IsamOK then + ReleaseVariableRecBuffer; {!!.50} + IsamExitCode(Pointer (NotAFileBlockPtr)); {!!.50} +end; + + +function BTSetVariableRecBuffer(Size : Word) : Boolean; +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); {!!.50} + if IsamOK then begin {!!.50} + BTSetVariableRecBuffer := CreateVariableRecBuffer(Size); + end + else begin {!!.50} + BTSetVariableRecBuffer := False; {!!.50} + end; {!!.50} + IsamExitCode(Pointer (NotAFileBlockPtr)); {!!.50} +end; + + +function AdjustVariableRecBuffer(Size : Word) : Boolean; {!!.50} +begin + if IsamVRecBufSize < Size then begin + ReleaseVariableRecBuffer; + AdjustVariableRecBuffer := CreateVariableRecBuffer(Size); + end + else begin + AdjustVariableRecBuffer := True; + end; +end; + + +function BTAdjustVariableRecBuffer(Size : Word) : Boolean; +begin + IsamEntryCode(Pointer (NotAFileBlockPtr), NoOptions); {!!.50} + if IsamOK then begin {!!.50} + BTAdjustVariableRecBuffer := AdjustVariableRecBuffer(Size);{!!.50} + end + else begin {!!.50} + BTAdjustVariableRecBuffer := False; {!!.50} + end; {!!.50} + IsamExitCode(Pointer (NotAFileBlockPtr)); {!!.50} +end; + + +procedure IsamAddRestVarRec(IFBPtr : IsamFileBlockPtr; + var RefNr : LongInt; + var Source; + Len : Word); +var + SPtr : PIsamVRecBuf; {!!.50} + CPtr : ^Word; + LPtr : ^LongInt; + SetLen, + Pos, + Number : Word; + Prev : LongInt; +begin + SetLen := Word(ILI (IFBPtr^.DIDPtr^[0]^.LenRec).Lo) - 7; + Number := Len Div SetLen; + if Number * SetLen <> Len then begin + Inc (Number); + end; + Pos := Pred (Number) * SetLen; + Prev := 0; + CPtr := Addr(IVRBPtr^ [Succ (SetLen)]); + LPtr := Addr(IVRBPtr^ [SetLen+3]); + SPtr := Addr(Source); + while Number > 0 do begin + IVRBPtr^ [0] := 1; + if Prev = 0 then begin + CPtr^ := Len-Pos; + end + else begin + CPtr^ := SetLen; + end; + Move(SPtr^ [Pos], IVRBPtr^ [1], CPtr^); + LPtr^ := Prev; + IsamAddRec(IFBPtr, Prev, IVRBPtr^); {!!.50} + if not IsamOK then Exit; + Dec (Number); + if Number <> 0 then + Pos := Pos-SetLen; + end; + RefNr := Prev; +end; + + +procedure BTAddVariableRec(IFBPtr : IsamFileBlockPtr; + var RefNr : LongInt; + var Source; + Len : Word); + {------} + procedure IsamAddVariableRec; {!!.50} + var + S : Word; + SPtr : PIsamVRecBuf; {!!.50} + CPtr : ^Word; + LPtr : ^LongInt; + begin + S := Word(ILI (IFBPtr^.DIDPtr^[0]^.LenRec).Lo); + if not AdjustVariableRecBuffer(S) then begin + IsamOK := False; + IsamError := 10040; + Exit; + end; + SPtr := Addr (Source); + CPtr := Addr (IVRBPtr^ [S-6]); + LPtr := Addr (IVRBPtr^ [S-4]); + if Len > (S-6) then begin + IsamAddRestVarRec(IFBPtr, RefNr, SPtr^ [S-6], Len-(S-6)); + if not IsamOK then Exit; + Len := S-6; + end + else begin + RefNr := 0; + end; + Move(SPtr^, IVRBPtr^, Len); {!!.50} + CPtr^ := Len; + LPtr^ := RefNr; + IsamAddRec(IFBPtr, RefNr, IVRBPtr^); {!!.50} + end; + {------} +begin + IsamEntryCode(IFBPtr, OptCheckLock or OptWriteRoutine); {!!.50} + if IsamOK then begin {!!.50} + IFBPtr^.CharConvProc(@Source, Len, False, {!!.50} + IFBPtr^.CCHookPtr); {!!.50} + IsamAddVariableRec; {!!.50} + if not IFBPtr^.CCDestrWrite then begin {!!.50} + IFBPtr^.CharConvProc(@Source, Len, True, {!!.50} + IFBPtr^.CCHookPtr); {!!.50} + end; {!!.50} + end; {!!.50} + IsamExitCode(IFBPtr); {!!.50} +end; + + +procedure IsamDeleteVariableRec(IFBPtr : IsamFileBlockPtr; {!!.50} + RefNr : LongInt); +var + NextRefNr : LongInt; + S : Word; +begin + S := ILI (IFBPtr^.DIDPtr^[0]^.LenRec).Lo; + repeat + IsamGetBlock(IFBPtr^.DatF, LongInt (S) * RefNr + LongInt (S-4), + SizeOf (LongInt), NextRefNr); + if not IsamOK then Exit; + IsamDeleteRec(IFBPtr, RefNr); {!!.50} + if not IsamOK then Exit; + RefNr := NextRefNr; + until NextRefNr = 0; +end; + + +procedure BTDeleteVariableRec(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt); +begin + IsamEntryCode(IFBPtr, OptCheckLock or OptWriteRoutine); {!!.50} + if IsamOK then + IsamDeleteVariableRec(IFBPtr, RefNr); {!!.50} + IsamExitCode(IFBPtr); {!!.50} +end; + + +procedure BTPutVariableRec( IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Source; + Len : Word); + {------} + procedure IsamPutVariableRec; {!!.50} + var + S : Word; + DelRefNr, + AddRefNr : LongInt; + SPtr : PIsamVRecBuf; {!!.50} + CPtr : ^Word; + LPtr : ^LongInt; + begin + S := Word (ILI (IFBPtr^.DIDPtr^[0]^.LenRec).Lo); + if not AdjustVariableRecBuffer(S) then begin + IsamOK := False; + IsamError := 10040; + Exit; + end; + SPtr := Addr (Source); + CPtr := Addr (IVRBPtr^ [S-6]); + LPtr := Addr (IVRBPtr^ [S-4]); + if Len > (S-6) then begin + IsamAddRestVarRec(IFBPtr, AddRefNr, SPtr^ [S-6], Len - (S-6)); + if not IsamOK then Exit; + Len := S-6; + end + else begin + AddRefNr := 0; + end; + IsamGetBlock(IFBPtr^.DatF, LongInt (S) * RefNr + LongInt (S-4), + SizeOf (LongInt), DelRefNr); + if not IsamOK then Exit; + if DelRefNr <> 0 then begin + IsamDeleteVariableRec(IFBPtr, DelRefNr); + if not IsamOK then Exit; + end; + Move(SPtr^, IVRBPtr^, Len); + CPtr^ := Len; + LPtr^ := AddRefNr; + IsamPutRec(IFBPtr, RefNr, IVRBPtr^); + end; + {------} +begin + IsamEntryCode(IFBPtr, OptCheckLock or OptWriteRoutine); {!!.50} + if IsamOK then begin {!!.50} + IFBPtr^.CharConvProc(@Source, Len, False, {!!.50} + IFBPtr^.CCHookPtr); {!!.50} + IsamPutVariableRec; {!!.50} + if not IFBPtr^.CCDestrWrite then begin {!!.50} + IFBPtr^.CharConvProc(@Source, Len, True, {!!.50} + IFBPtr^.CCHookPtr); {!!.50} + end; {!!.50} + end; {!!.50} + IsamExitCode(IFBPtr); {!!.50} +end; + + +procedure IsamGetVariableRecPart(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Dest; + var Len : Word; + UseRO : Boolean); + {------} + function GetVRec : Boolean; + var + SecSize : Word; + DestPos : Word; + SrcPos : Word; + LeftToRead : Word; + LenToMove : Word; + DestPtr : PIsamVRecBuf; {!!.50} + LenPtr : ^Word; + RefPtr : ^LongInt; + begin + GetVRec := True; + SecSize := Word (ILI(IFBPtr^.DIDPtr^[0]^.LenRec).Lo); + LenPtr := @IVRBPtr^ [SecSize-6]; {Points to actual length of record + section} + RefPtr := @IVRBPtr^ [SecSize-4]; {Points to next segment reference} + DestPtr := @Dest; {Points to base of output area} + DestPos := 0; {Position of data in output area} + SrcPos := 0; {Position of data in input section} + RefPtr^ := RefNr; {First section to read} + LeftToRead := Len; {Bytes left to read} + Len := 0; {in case we exit with error} + + repeat + {--Read the next section} + if (DestPos = 0) and UseRO then begin + IsamGetRecReadOnly(IFBPtr, RefPtr^, IVRBPtr^); {!!.50} + if IsamError = 10205 then begin + GetVRec := False; + IsamClearOK; + end; + end + else begin + IsamGetRec(IFBPtr, RefPtr^, IVRBPtr^); {!!.50} + end; + if not IsamOK then Exit; + + {--Transfer section to destination} + if LenPtr^ > LeftToRead then begin + LenToMove := LeftToRead; + end + else begin + LenToMove := LenPtr^; + end; + Move(IVRBPtr^ [SrcPos], DestPtr^ [DestPos], LenToMove); + + {--Move to next area of destination} + Inc(DestPos, LenToMove); + Dec(LeftToRead, LenToMove); + + {--Data starts at position 1 for all sections but the first} + SrcPos := 1; + until (RefPtr^ = 0) or (LeftToRead = 0); + + {--Return the actual length} + Len := DestPos; + end; + {------} +var + Options : Word; {!!.50} +begin + if BTRecIsLocked(IFBPtr, RefNr) then begin {!!.50} + Options := NoOptions; {!!.50} + end + else begin {!!.50} + Options := OptReadPrefix; {!!.50} + end; {!!.50} + IsamEntryCode(IFBPtr, Options); {!!.50} + if AdjustVariableRecBuffer {!!.50} + (Word (ILI (IFBPtr^.DIDPtr^[0]^.LenRec).Lo)) then begin + if not GetVRec and IsamOK then begin + IsamOK := False; + IsamError := 10205; + end; + if IsamOK or (IsamError = 10205) then begin {!!.50} + IFBPtr^.CharConvProc(@Dest, Len, True, {!!.50} + IFBPtr^.CCHookPtr); {!!.50} + end; {!!.50} + end + else begin {!!.50} + IsamOK := False; {!!.50} + IsamError := 10040; {!!.50} + end; {!!.50} + IsamExitCode(IFBPtr); {!!.50} +end; + + +procedure BTGetVariableRecPart(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Dest; + var Len : Word); +begin + IsamGetVariableRecPart(IFBPtr, RefNr, Dest, Len, False); +end; + + +procedure BTGetVariableRec(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Dest; + var Len : Word); +begin + Len := MaxVariableRecLength; + IsamGetVariableRecPart(IFBPtr, RefNr, Dest, Len, False); +end; + + +procedure BTGetVRecPartReadOnly(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Dest; + var Len : Word); +begin + IsamGetVariableRecPart(IFBPtr, RefNr, Dest, Len, True); +end; + + +procedure BTGetVRecReadOnly(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Dest; + var Len : Word); +begin + Len := MaxVariableRecLength; + IsamGetVariableRecPart(IFBPtr, RefNr, Dest, Len, True); +end; + + +procedure BTGetVariableRecLength(IFBPtr : IsamFileBlockPtr; + RefNr : LongInt; + var Len : Word); + {------} + procedure IsamGetVariableRecLength; {!!.50} + var + S : Word; + Inf : packed Record + L : Word; + NextRefNr : LongInt; + end; + begin + S := Word(ILI (IFBPtr^.DIDPtr^[0]^.LenRec).Lo); + if not AdjustVariableRecBuffer(S) then begin + IsamOK := False; + IsamError := 10040; + Exit; + end; + Len := 0; + repeat + IsamGetBlock(IFBPtr^.DatF, LongInt (S) * RefNr + LongInt (S-6), + SizeOf (Inf), Inf); + if not IsamOK then Exit; + with Inf do begin + if Len > MaxVariableRecLength - L then begin + IsamOK := False; + IsamError := 10415; + Exit; + end; + RefNr := NextRefNr; + Inc (Len, L); + end; + until RefNr = 0; + end; + {------} +var + Options : Word; {!!.50} +begin + if BTRecIsLocked(IFBPtr, RefNr) then begin {!!.50} + Options := NoOptions; {!!.50} + end + else begin {!!.50} + Options := OptReadPrefix; {!!.50} + end; {!!.50} + IsamEntryCode(IFBPtr, Options); {!!.50} + if IsamOK then + IsamGetVariableRecLength; {!!.50} + IsamExitCode(IFBPtr); {!!.50} +end; + +end. diff --git a/src/wc_sdk/vreorg.pas b/src/wc_sdk/vreorg.pas new file mode 100644 index 0000000..4fba977 --- /dev/null +++ b/src/wc_sdk/vreorg.pas @@ -0,0 +1,91 @@ +{********************************************************************} +{* VREORG.PAS - reorganize variable-length fileblock *} +{********************************************************************} + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + + +{--Conditional defines and compiler options} +{$I btdefine.inc} +{$IFDEF CanAllowOverlays} + {$O+,F+} +{$ENDIF} + +Unit + VReOrg; + +Interface + +Uses + BTBase, + BTIsBase, + Filer, {!!.TP} + Restruct, + Reindex; + + Procedure ReorgVFileBlock ( FBlName : IsamFileBlockName; + DatSLen : LongInt; + NumberOfKeys : Word; + IID : IsamIndDescr; + DatSLenOld : LongInt; + MaxDiffBytes : Word; + BuildKeyFunc : FuncBuildKey; + ChangeDatSFunc : FuncChangeDatS ); + {-Reorganizes a variable record length fileblocks data and index + structure} + + +Implementation + + Procedure ReorgVFileBlock ( FBlName : IsamFileBlockName; + DatSLen : LongInt; + NumberOfKeys : Word; + IID : IsamIndDescr; + DatSLenOld : LongInt; + MaxDiffBytes : Word; + BuildKeyFunc : FuncBuildKey; + ChangeDatSFunc : FuncChangeDatS ); + + Var + Dummy : Boolean; + + Begin + RestructFileBlock ( FBlName, DatSLen, DatSLenOld, True, MaxDiffBytes, + ChangeDatSFunc, BTNoCharConvert, Nil ); + If Not IsamOK Then Exit; + If NumberOfKeys > 0 Then Begin + ReIndexFileBlock ( FBlName, NumberOfKeys, IID, True, + BuildKeyFunc, True, Dummy, + BTNoCharConvert, Nil ); + End; + End; + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/wbrowser.pas b/src/wc_sdk/wbrowser.pas new file mode 100644 index 0000000..141ba1a --- /dev/null +++ b/src/wc_sdk/wbrowser.pas @@ -0,0 +1,2068 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower B-Tree Filer + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1986-2002 + * the Initial Developer. All Rights Reserved. + * + * Based in part on code written by Ralf Nagel + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{$C MOVEABLE,DEMANDLOAD,DISCARDABLE} + +{--Conditional defines and compiler options that affect this unit} + {$I brdefopt.inc} + {$X+,F-,V-,B-,S-,I-,R-} + {$IFDEF CanSetOvrflowCheck} + {$Q-} + {$ENDIF} + + +{$IFDEF Win32} + !! Error - this unit cannot be compiled for 32-bit +{$ENDIF} + +Unit WBrowser; + +Interface + +Uses +{$IFDEF Ver80} {!!.51} + Messages, {!!.51} +{$ENDIF} {!!.51} + WinTypes, + WinProcs, +{$IFDEF Ver10} + WObjects, +{$ELSE} + {$IFDEF Ver15} + WObjects, + {$ELSE} + Objects, + OWindows, + ODialogs, + {$ENDIF} +{$ENDIF} + Strings, + LowBrows, + MedBrows, + HiBrows; + +Const +{$IFDEF BRUseShell} + HardError = OpSBase.HardError; + ProgrammingError = OpSBase.ProgrammingError; +{$ENDIF} +{$IFDEF BRUseIsam} + HardError = 4; + ProgrammingError = 5; +{$ENDIF} + + +Type + PBrowserWindow = ^TBrowserWindow; + + PLowWinBrowser = ^LowWinBrowser; + LowWinBrowser = Object ( BRHBrowser ) + Owner : PBrowserWindow; + OnHeap : Boolean; + + Constructor Init ( ParOnHeap : Boolean; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + Var ADatS; + AIsVarRec : Boolean ); + + Destructor Done; Virtual; + + Function BuildRow ( Var RR : RowRec ) : Integer; Virtual; + Function PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; Virtual; + + Procedure ShowErrorOccured ( EClass : Integer ); Virtual; {!!.51} + Function PreCompletePage : Integer; Virtual; + Function PostCompletePage : Integer; Virtual; + End; + + TabTable = Array [1..$7F00] Of Integer; + TabTablePtr = ^TabTable; + + FontInfo = Record {!!.03} + Font : THandle; + ChHeightExtra, + ChHeight, + ChWidth, + ChRefWidth : Word; {!!.04} + FixedPitch : Boolean; + End; + + TBrowserWindow = Object (TWindow) + DoTheFilter, + FilterInProgress : Boolean; {!!.03} + BrowserPtr : PLowWinBrowser; + + FontDescr : FontInfo; {!!.03b} + HorizOfs : Integer; {!!.03b} + Width, {!!.03b} + {-Set correct even before OWL gets wm_Size} + FullPage, {!!.03b} + FirstRow, {!!.03b} + MaxHorizOfs : Word; {!!.03b} + + TextMargin : TRect; {!!.03b} + + PaintRaster : Boolean; {!!.05} + + {--Internal use only fields} + lwBackGrErase : Boolean; {!!.03b} + lwNoPaintHFCg : Boolean; {!!.05} + + + Constructor Init ( AParent : PWindowsObject; + ATitle : PChar ); + + Destructor Done; Virtual; + + Function ConnectLowBrowser ( ABrowserPtr : PLowWinBrowser; + AHeader, + AFooter : BRLRowEltString ) : Boolean; + + {--The following functions must be overwritten in descending objects} + Function BuildRow ( Var RR : RowRec ) : Integer; Virtual; + + {--The following routines may be overwritten in descending objects} + Function PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; Virtual; + Procedure JustFiltered ( Rejected : Boolean ); Virtual; {!!.03} + Procedure EndFilter; Virtual; {!!.03} + + Procedure ShowErrorOccured ( EClass : Integer ); Virtual; {!!.51} + Procedure ShowFilterWorking ( CallState : Integer; + Rejected : Boolean ); Virtual; + Function PreCompletePage : Integer; Virtual; + Function PostCompletePage : Integer; Virtual; + + Function HandleChar ( Var Msg : TMessage ) : Boolean; Virtual; + + Procedure SetTheFont; Virtual; + Procedure DeleteTheFont; Virtual; + Procedure SetCharValues; Virtual; {!!.03b} + Procedure SetMargins; Virtual; {!!.03b} + + Function AdjustHorizOfs ( Delta : Integer) : Integer; Virtual;{!!.03b} + Function CalcMaxWidth : Integer; Virtual; {!!.03b} + Procedure LineDown; Virtual; {!!.03b} + Procedure LineUp; Virtual; {!!.03b} + Procedure PageDown; Virtual; {!!.03b} + Procedure PageUp; Virtual; {!!.03b} + Procedure FirstPage; Virtual; {!!.03b} + Procedure LastPage; Virtual; {!!.03b} + Procedure MoveToRelPos ( Pos : Word ); Virtual; {!!.03b} + Procedure LineRight; Virtual; {!!.03b} + Procedure LineLeft; Virtual; {!!.03b} + Procedure PageRight; Virtual; {!!.03b} + Procedure PageLeft; Virtual; {!!.03b} + Procedure LeftHome; Virtual; {!!.03b} + Procedure RightHome; Virtual; {!!.03b} + Procedure MoveToHorizPos ( Pos : Word ); Virtual; {!!.03b} + + Procedure GetBrowserTextRect ( Var TextRect : TRect ); Virtual; + {!!.03b} + Procedure GetRowAreaRect ( Var Rect : TRect ); Virtual; {!!.03b} + Function GetTextOutPosY ( LineNr : Word ) : Integer; Virtual; {!!.03b} + Function GetLineNrFromY ( Y : Integer ) : Word; Virtual; {!!.03b} + Function XYPosInRect ( X, Y : Integer; Rect : TRect ) : Boolean; + {!!.03b} + Function TotalSpaceForLines ( Rect : TRect ) : Word; Virtual; {!!.03b} + + Procedure FillClientGaps ( DC : HDC ); Virtual; {!!.05} + Procedure DisplayRow ( I : Integer; + DC : HDC; + Inverse : Boolean ); Virtual; + + Procedure WriteHeader ( Var HeaderLine : BRLRowEltString; {!!.03b} + DC : HDC ); Virtual; + Procedure WriteDataLine ( Var DataLine : BRLRowEltString; {!!.03b} + LineNr : Word; + DC : HDC; + Inverse : Boolean ); Virtual; + Procedure WriteFooter ( Var FooterLine : BRLRowEltString; {!!.03b} + DC : HDC ); Virtual; + Procedure DrawSeparator ( Pos : Word; {!!.03b} + Color : TColorRef; + DC : HDC ); Virtual; + + Function WriteStringOut ( Var S : String; {!!.03b} + LineNr : Word; + DC : HDC; + XOfs : Integer ) : Word; Virtual; + + Procedure GetHeaderFooterColor {!!.03b} + ( Var Color, BkColor : TColorRef; ForHeader : Boolean ); Virtual; + Procedure GetHighlightColor {!!.03b} + ( Var Color, BkColor : TColorRef ); Virtual; + Procedure GetNormalColor {!!.03b} + ( Var Color, BkColor : TColorRef ); Virtual; + Function UseSeparator {!!.03b} + ( Var Color : TColorRef ) : Boolean; Virtual; + + Procedure Paint ( PaintDC : HDC; + Var PaintStruct : TPaintStruct ); Virtual; + + Function CanCallLowBrowser : Boolean; Virtual; + Procedure SetupWindow; Virtual; + + Procedure FirstUserInit; Virtual; + + {--The following routines may be called from outside} + Procedure SetHeaderFooter ( AHeader, + AFooter : BRLRowEltString ); + Procedure SetLowHighKey ( ALowKey, + AHighKey : GenKeyStr ); + Procedure GetLowHighKey ( Var ALowKey, {!!.03} + AHighKey : GenKeyStr ); + + Procedure SetAndUpdateBrowserScreen ( NewKeyStr : GenKeyStr; + NewRef : LongInt ); + Procedure UpdateBrowserScreen; + Procedure ReInitUpdateBrowserScreen; {!!.03b} + + Function GetCurrentRec ( Var Match : Boolean ) : Integer; {!!.03} + Function GetCurrentKeyNr : Word; + Function GetCurrentKeyStr : String; + Function GetCurrentDatRef : LongInt; + Function GetCurNrOfLines : Word; {!!.03} + Procedure SetKeyNr ( Value : Word ); + + Function SetSuppressTimer ( DoSuppr : Boolean ) : Boolean; + Function GetSuppressTimer : Boolean; + + Procedure EnableFilter ( FilterOn : Boolean ); Virtual; {!!.03}{!!.51} + Function FilterIsOn ( Var InProgress : Boolean ) : Boolean; {!!.03} + + Procedure SetHeaderNoUpdate ( AHeader : BRLRowEltString ); Virtual; + {!!.03b} + Procedure SetFooterNoUpdate ( AFooter : BRLRowEltString ); Virtual; + {!!.03b} + Function GetHeader : BRLRowEltString; {!!.03b} + Function GetFooter : BRLRowEltString; {!!.03b} + + Function TotalCharHeight : Word; {!!.03b} + + Procedure PosClientCorruption; {!!.04} + Procedure MarkClientCorruptablePhase; {!!.04} + Function ClientPosCorrupted : Boolean; {!!.04} + + {--The following routines may be called from overridden routines} + Function GetThisRec ( Var RR : RowRec ) : Integer; + Function BuildBrowScreenRow ( Var RR : RowRec ) : Integer; + + {--The following routines should not be overridden in descending objects} + Procedure InitFields; Virtual; + Function GetClassName : PChar; Virtual; + Procedure Reinit; Virtual; {!!.03b} + Procedure GetWindowClass ( Var WndClass : TWndClass ); Virtual;{!!.03} + Procedure NewSize; Virtual; + {!!.03b wmPaint removed} + Procedure WMSize ( Var Msg : TMessage ); Virtual + wm_First + wm_Size; + Procedure WMLButtonDown ( Var Msg : TMessage); Virtual + wm_First + wm_LButtonDown; + Procedure WMKillFocus ( Var Msg : TMessage); Virtual {!!.03b} + wm_First + wm_KillFocus; + {!!.03 wmSetFocus removed} + Procedure WMNCMouseMove ( Var Msg : TMessage ); Virtual {!!.03b} + wm_First + wm_NCMouseMove; + Procedure WMMouseMove ( Var Msg : TMessage ); Virtual + wm_First + wm_MouseMove; + Procedure WMTimer ( Var Msg : TMessage ); Virtual + wm_First + wm_Timer; + Procedure WMVScroll ( Var Msg : TMessage ); Virtual + wm_First + wm_VScroll; + Procedure WMHScroll ( Var Msg : TMessage ); Virtual + wm_First + wm_HScroll; + Procedure WMChar ( Var Msg : TMessage ); Virtual + wm_First + wm_Char; + Procedure WMKeyDown ( Var Msg : TMessage ); Virtual + wm_First + wm_KeyDown; + Procedure WMKeyUp ( Var Msg : TMessage ); Virtual + wm_First + wm_KeyUp; + + {--Internal use only methods} + Procedure InvalidateBrowserScreen; + Procedure lwUpdateVertScrollBar; + Procedure lwUpdateHorzScrollBar; + + Private + lwVertScale, + lwThumbVTrack, + lwThumbHTrack : Word; + + lwHeader, + lwFooter : BRLRowEltString; + + lwDoMouseMove, {!!.03b} + lwCtrlDown, + lwShiftDown : Boolean; + + lwSupprTimer : Boolean; + + lwFInitDone : Boolean; + + lwPosClientCorruption : Boolean; {!!.04} + + {--The following routines are internal use only} + Procedure lwFirstInit; {!!.03b} + Procedure lwSetAndUpdateBrowserScreen ( NewKeyStr : GenKeyStr; + NewRef : LongInt ); + Procedure lwUpdateBrowserScreen; + Procedure lwNewSize; {!!.03b} + End; + + +Implementation + + Const + VertScrollScale = 63; + +(************************************************************************) + Constructor LowWinBrowser.Init + ( ParOnHeap : Boolean; + ADrvOrFileBlockPtr : Pointer; + ANumberOfEltsPerRow : Word; + ANumberOfRows : Word; + AKeyNr : Word; + ALKey, + AHKey : GenKeyStr; + Var ADatS; + AIsVarRec : Boolean ); + + Begin + Owner := Nil; + OnHeap := ParOnHeap; + If Not BRHBrowser.Init ( ADrvOrFileBlockPtr, ANumberOfEltsPerRow, + ANumberOfRows, ALKey, AHKey, False, ADatS, AIsVarRec ) Then Fail; + KeyNr := AKeynr; + End; + + + Destructor LowWinBrowser.Done; + + Begin + BRHBrowser.Done; + If Owner <> Nil Then + Owner^.BrowserPtr := Nil; + Owner := Nil; + End; + + + Function LowWinBrowser.BuildRow ( Var RR : RowRec ) : Integer; + + Begin + BuildRow := Owner^.BuildRow ( RR ); + End; + + + Function LowWinBrowser.PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; + + Var + LResult : Integer; {!!.51} + Begin + LResult := Owner^.PerformFilter ( RR, UseIt ); {!!.51} + If ( LResult = NoError ) And Owner^.DoTheFilter Then Begin {!!.51} + Owner^.JustFiltered ( Not UseIt ); + End; + PerformFilter := LResult; {!!.51} + End; + + + Procedure LowWinBrowser.ShowErrorOccured ( EClass : Integer ); {!!.51} + + Begin + Owner^.ShowErrorOccured ( EClass ); {!!.51} + Owner^.EndFilter; + End; + + + Function LowWinBrowser.PreCompletePage : Integer; + + Begin + PreCompletePage := Owner^.PreCompletePage; + End; + + + Function LowWinBrowser.PostCompletePage : Integer; + + Begin + PostCompletePage := Owner^.PostCompletePage; + Owner^.EndFilter; + End; + + +(************************************************************************) + + Procedure TBrowserWindow.InitFields; + + Begin + Attr.Style := Attr.Style Or ws_VScroll Or ws_HScroll; + + lwBackGrErase := False; + lwNoPaintHFCg := False; {!!.05} + lwFInitDone := False; + SetHeaderNoUpdate ( '' ); {!!.03b} + SetFooterNoUpdate ( '' ); {!!.03b} + + lwDoMouseMove := False; {!!.03b} + lwCtrlDown := False; + lwShiftDown := False; + + HorizOfs := 0; + lwVertScale := VertScrollScale; + lwThumbVTrack := $FFFF; {!!.03b} + + lwSupprTimer := False; + + BrowserPtr := Nil; + + DoTheFilter := False; + FilterInProgress := False; + PaintRaster := False; + + lwPosClientCorruption := False; + End; + + + Constructor TBrowserWindow.Init ( AParent : PWindowsObject; + ATitle : PChar ); + + Begin + If Not TWindow.Init ( AParent, ATitle ) Then Fail; + InitFields; + End; + + + Destructor TBrowserWindow.Done; + + Begin + If BrowserPtr <> Nil Then Begin + If BrowserPtr^.OnHeap Then Begin + Dispose ( BrowserPtr, Done ) + End Else Begin + BrowserPtr^.Done; + End; + End; + BrowserPtr := Nil; + DeleteTheFont; + TWindow.Done; + End; + + + Procedure TBrowserWindow.InvalidateBrowserScreen; + + Var + R : TRect; + + Begin + lwNoPaintHFCg := False; {!!.05} + If Not GetUpdateRect ( hWindow, R, False ) Then Begin + InvalidateRect ( hWindow, Nil, lwBackGrErase ); + End; + End; + + + Procedure TBrowserWindow.DeleteTheFont; + + Begin + If FontDescr.Font > 0 Then DeleteObject ( FontDescr.Font ); + End; + + + Procedure TBrowserWindow.SetTheFont; + + Var + LogFont : TLogFont; + + Begin + With FontDescr Do Begin + Font := GetStockObject ( SYSTEM_Fixed_FONT ); + If Font > 0 Then Begin + GetObject ( Font, SizeOf (LogFont), @LogFont ); + With LogFont Do Begin + lfPitchAndFamily := ff_Modern Or Fixed_Pitch; + lfWeight := FW_Normal; + End; + Font := CreateFontIndirect ( LogFont ); + End; + FixedPitch := True; + End; + End; + + + Function TBrowserWindow.HandleChar ( Var Msg : TMessage ) : Boolean; + + Begin + HandleChar := False; + End; + + + Function TBrowserWindow.BuildRow ( Var RR : RowRec ) : Integer; + + Begin + RunError ( 211 ); + End; + + + Function TBrowserWindow.PerformFilter ( Var RR : RowRec; + Var UseIt : Boolean ) : Integer; + + Begin + UseIt := True; + PerformFilter := NoError; + End; + + + Procedure TBrowserWindow.JustFiltered ( Rejected : Boolean ); + + Begin + If FilterInProgress Then Begin + ShowFilterWorking ( 0, Rejected ); + End Else Begin + FilterInProgress := True; + ShowFilterWorking ( -1, Rejected ); + End; + End; + + + Procedure TBrowserWindow.EndFilter; + + Begin + If FilterInProgress Then Begin + FilterInProgress := False; + ShowFilterWorking ( 1, False ); + End; + End; + + + Procedure TBrowserWindow.ShowErrorOccured ( EClass : Integer ); {!!.51} + + Begin + MessageBeep ( 0 ); + End; + + + Procedure TBrowserWindow.ShowFilterWorking ( CallState : Integer; + Rejected : Boolean ); + + Begin + End; + + + Function TBrowserWindow.PreCompletePage : Integer; + + Begin + PreCompletePage := NoError; + End; + + + Function TBrowserWindow.PostCompletePage : Integer; + + Begin + PostCompletePage := NoError; + End; + + + Function TBrowserWindow.CanCallLowBrowser : Boolean; {!!.03} + + Begin + CanCallLowBrowser := (BrowserPtr <> Nil) And lwFInitDone + And IsWindow ( HWindow ) And BrowserPtr^.BrowserCallAllowed + And Not FilterInProgress; + End; + + + Procedure TBrowserWindow.FirstUserInit; + + Begin + End; + + + Procedure TBRowserWindow.SetupWindow; + + Begin + TWindow.SetupWindow; + If BrowserPtr <> Nil Then lwFirstInit; + End; + + + Procedure TBrowserWindow.SetHeaderFooter ( AHeader, + AFooter : BRLRowEltString ); + + Begin + If Not CanCallLowBrowser Then Exit; + SetHeaderNoUpdate ( AHeader ); {!!.03b} + SetFooterNoUpdate ( AFooter ); {!!.03b} + NewSize; {!!.03b} + UpdateBrowserScreen; {!!.03b} + End; + + + Procedure TBrowserWindow.SetLowHighKey ( ALowKey, + AHighKey : GenKeyStr ); + + Begin + If Not CanCallLowBrowser Then Exit; + BrowserPtr^.LowKey := ALowKey; + BrowserPtr^.HighKey := AHighKey; + End; + + + Procedure TBrowserWindow.GetLowHighKey ( Var ALowKey, + AHighKey : GenKeyStr ); + + Begin + ALowKey := ''; + AHighKey := ''; + If Not CanCallLowBrowser Then Exit; + ALowKey := BrowserPtr^.LowKey; + AHighKey := BrowserPtr^.HighKey; + End; + + + Procedure TBrowserWindow.SetAndUpdateBrowserScreen + ( NewKeyStr : GenKeyStr; + NewRef : LongInt ); + + Begin + If CanCallLowBrowser Then Begin + lwSetAndUpdateBrowserScreen ( NewKeyStr, NewRef ); + End; + End; + + + Procedure TBrowserWindow.UpdateBrowserScreen; + + + Begin + If CanCallLowBrowser Then Begin + lwUpdateBrowserScreen; + End; + End; + + + Procedure TBrowserWindow.ReInitUpdateBrowserScreen; + + Begin + If CanCallLowBrowser Then Begin + InvalidateRect ( hWindow, Nil, True ); {!!.03b} + NewSize; {!!.03b} + UpdateBrowserScreen; + End; + End; + + + Function TBrowserWindow.GetThisRec ( Var RR : RowRec ) : Integer; + + Begin + GetThisRec := ProgrammingError; + If BrowserPtr = Nil Then Exit; + GetThisRec := BrowserPtr^.BRGetRec ( RR, False, False ); + End; + + + Function TBrowserWindow.BuildBrowScreenRow ( Var RR : RowRec ) : Integer; + + Begin + BuildBrowScreenRow := ProgrammingError; + If BrowserPtr = Nil Then Exit; + BuildBrowScreenRow := BrowserPtr^.BuildBrowScreenRow ( RR ); + End; + + + Function TBrowserWindow.GetCurrentRec ( Var Match : Boolean ) : Integer; + + Var + LResult : Integer; {!!.51} + + Begin + Match := False; + GetCurrentRec := ProgrammingError; + If Not CanCallLowBrowser Then Exit; + With BrowserPtr^ Do Begin + GetCurrentRec := GetRowMatchingRec ( BSAPtr^[GetCurRow]^, + True, True, Match ); + End; + End; + + + Function TBrowserWindow.GetCurrentKeyNr : Word; + + Begin + GetCurrentKeyNr := $FFFF; {!!.04} + If BrowserPtr = Nil Then Exit; {!!.03b} + GetCurrentKeyNr := BrowserPtr^.KeyNr; + End; + + + Function TBrowserWindow.GetCurrentKeyStr : String; + + Begin + GetCurrentKeyStr := ''; + If Not CanCallLowBrowser Then Exit; + GetCurrentKeyStr := BrowserPtr^.GetCurrentKeyStr; + End; + + + Function TBrowserWindow.GetCurrentDatRef : LongInt; + + Begin + GetCurrentDatRef := 0; + If Not CanCallLowBrowser Then Exit; + GetCurrentDatRef := BrowserPtr^.GetCurrentDatRef; + End; + + + Function TBrowserWindow.GetCurNrOfLines : Word; + + Begin + GetCurNrOfLines := FullPage; + End; + + + Procedure TBrowserWindow.SetKeyNr ( Value : Word ); + + Begin + If CanCallLowBrowser Then Begin + BrowserPtr^.KeyNr := Value; + End; + End; + + + Function TBrowserWindow.SetSuppressTimer ( DoSuppr : Boolean ) : Boolean; + + Begin + SetSuppressTimer := lwSupprTimer; + lwSupprTimer := DoSuppr; + End; + + + Function TBrowserWindow.GetSuppressTimer : Boolean; + + Begin + GetSuppressTimer := lwSupprTimer; + End; + + + Procedure TBrowserWindow.EnableFilter ( FilterOn : Boolean ); {!!.51} + + Begin + DoTheFilter := FilterOn; {!!.51} + If FilterInProgress And Not FilterOn Then Begin {!!.51} + EndFilter; {!!.03b} + End; + End; + + + Function TBrowserWindow.FilterIsOn ( Var InProgress : Boolean ) + : Boolean; + + Begin + FilterIsOn := DoTheFilter; + InProgress := FilterInProgress; + End; + + + Procedure TBrowserWindow.SetHeaderNoUpdate ( AHeader : BRLRowEltString ); + + Begin + lwHeader := AHeader; + End; + + + Procedure TBrowserWindow.SetFooterNoUpdate ( AFooter : BRLRowEltString ); + + Begin + lwFooter := AFooter; + End; + + + Function TBrowserWindow.GetHeader : BRLRowEltString; + + Begin + GetHeader := lwHeader; + End; + + + Function TBrowserWindow.GetFooter : BRLRowEltString; + + Begin + GetFooter := lwFooter; + End; + + + Function TBrowserWindow.TotalCharHeight : Word; + + Var + LResult : Word; {!!.51} + + Begin + LResult := FontDescr.ChHeight + FontDescr.ChHeightExtra; {!!.51} + If LResult = 0 Then LResult := 1; {!!.51} + TotalCharHeight := LResult; {!!.51} + End; + + + Procedure TBrowserWindow.PosClientCorruption; {!!.04} + + Begin + lwPosClientCorruption := True; + End; + + + Procedure TBrowserWindow.MarkClientCorruptablePhase; {!!.04} + + Begin + lwPosClientCorruption := False; + End; + + + Function TBrowserWindow.ClientPosCorrupted : Boolean; {!!.04} + + Begin + ClientPosCorrupted := lwPosClientCorruption; + End; + + + Function TBrowserWindow.AdjustHorizOfs ( Delta : Integer) : Integer; + + Var + Offset : LongInt; + + Begin + Offset := LongInt (HorizOfs) + Delta; + If Offset < 0 Then Begin + Offset := 0; + End Else Begin + If OffSet > MaxHorizOfs Then Begin + Offset := MaxHorizOfs; + End; + End; + AdjustHorizOfs := Offset; + End; + + + Function TBrowserWindow.CalcMaxWidth : Integer; {!!.03b} + + Begin + CalcMaxWidth := MaxCols * FontDescr.ChWidth; + End; + + + Procedure TBrowserWindow.lwUpdateVertScrollBar; + + Var + RelPos : Word; + + Begin + BrowserPtr^.HGetApprRelPos ( RelPos, lwVertScale, GetCurrentKeyStr, + GetCurrentDatRef ); + If Not BrowserPtr^.StatusOK Then RelPos := 0; + If Attr.Style And ws_VScroll <> 0 Then Begin {!!.03} + SetScrollPos ( HWindow, SB_Vert, RelPos, True ); + End; + End; + + + Procedure TBrowserWindow.lwUpdateHorzScrollBar; + + Begin + If MaxHorizOfs > 0 Then Begin + If Attr.Style And ws_HScroll <> 0 Then Begin {!!.03} + SetScrollPos ( HWindow, SB_Horz, HorizOfs, True ); + End; + End; + End; + + + Procedure TBrowserWindow.SetCharValues; + + Var + UsedDC : HDC; + TM : TTextMetric; + + Begin + UsedDC := GetDC ( HWindow ); + + With FontDescr Do Begin + ChHeight := 1; + ChWidth:= 1; + ChRefWidth := 1; {!!.04} + ChHeightExtra := 0; {!!.03b} + If Font > 0 Then SelectObject ( UsedDC, Font); + If GetTextMetrics ( UsedDC, TM ) Then Begin + With TM Do Begin + ChHeight := tmHeight + tmExternalLeading; + ChWidth := (tmMaxCharWidth + tmAveCharWidth) Shr 1; {!!.04} + ChRefWidth := tmAveCharWidth; {!!.04} + End; + End; + End; + ReleaseDC ( HWindow, UsedDC ); + End; + + + Procedure TBrowserWindow.SetMargins; {!!.03b} + + Begin + FillChar ( TextMargin, SizeOf (TextMargin), 0 ); + End; + + + Procedure TBrowserWindow.Reinit; + {-Initialize variables that can change if the window is resized} + Var + R : TRect; + MaxWidth : Word; + DC : HDC; + RG : HRgn; + + Begin + SetCharValues; + + {--Get Rectangle to use} + GetBrowserTextRect ( R ); {!!.03b} + + {--Vertical stuff in rows} + FullPage := TotalSpaceForLines ( R ) Div TotalCharHeight; {!!.03b} + FirstRow := 1; + If lwHeader <> '' Then Begin + Dec (FullPage); + Inc (FirstRow); + End; + If lwFooter <> '' Then Dec (FullPage); + + If (FullPage > $FFF0) Or (FullPage = 0) Then FullPage := 1; {!!.03b} + {-Holds functionality of this browser when resized below 1} {!!.03b} + BrowserPtr^.AdjustNrOfRows ( FullPage ); {!!.03b} + + {--Horizontal stuff in pixels} + Width := R.Right - R.Left; + MaxWidth := CalcMaxWidth; + If Width > MaxWidth Then Begin + MaxHorizOfs := 0; + End Else Begin + MaxHorizOfs := MaxWidth - Width; + End; + HorizOfs := AdjustHorizOfs ( 0 ); {!!.03b} + If Attr.Style And ws_HScroll <> 0 Then Begin {!!.03} + SetScrollRange ( HWindow, SB_Horz, 0, MaxHorizOfs, False ); + SetScrollPos ( HWindow, SB_Horz, HorizOfs, True ); + End; + + End; + + + Procedure TBrowserWindow.LineDown; + + Var + LRow : Word; + Moved : Word; + CR : Word; + R : TRect; + Dummy, + Update : Boolean; + TRR : RowRec; + + Begin + Update := True; + lwNoPaintHFCg := True; {!!.05} + With BrowserPtr^ Do Begin + LRow := GetLastRow; + CR := GetCurRow; + If (CR = LRow) Or (LRow = 0) Then Begin + MarkClientCorruptablePhase; {!!.04} + HBuildNextPage ( 1, Moved, True, 0, Dummy ); + If StatusOK Then Begin + If OtherAction Then Begin + InvalidateBrowserScreen; {!!.03b} + End Else Begin + If Moved = 1 Then Begin + If FullPage <> 1 Then Begin + If LRow = GetLastRow Then Begin + If ClientPosCorrupted Then Begin {!!.04} + InvalidateBrowserScreen; {!!.04} + End Else Begin {!!.04} + GetRowAreaRect ( R ); {!!.04} + Dec (R.Bottom, FontDescr.ChHeightExtra); {!!.04} + CopyRowRec ( BSAPtr^ [LRow]^, TRR ); + CopyRowRec ( BSAPtr^ [Pred (LRow)]^, BSAPtr^ [LRow]^ ); + DisplayRow ( LRow, 0, False); + CopyRowRec ( TRR, BSAPtr^ [LRow]^ ); + {-Copy RowRec to avoid scrolling the highlight bar} + ScrollWindow ( HWindow, 0, -TotalCharHeight, @R, @R ); + {!!.03b} + ValidateRect ( HWindow, Nil ); {!!.03b} + End; {!!.04} + End Else Begin + SetCurRow ( Succ (CR) ); + DisplayRow ( LRow, 0, False); + End; + End; + DisplayRow ( GetCurRow, 0, True); + End Else Begin + Update := False; + End; + End; + End Else Begin + Update := False; + End; + End Else Begin + DisplayRow ( CR , 0, False); + SetCurRow ( Succ (CR) ); + DisplayRow ( GetCurRow, 0, True); + End; + End; + If Update Then lwUpdateVertScrollBar; + End; + + + Procedure TBrowserWindow.LineUp; + + Var + Moved : Word; + CR : Word; + R : TRect; + Dummy, + Update : Boolean; + TRR : RowRec; + + Begin + Update := True; + lwNoPaintHFCg := True; {!!.05} + With BrowserPtr^Do Begin + CR := GetCurRow; + If CR = 1 Then Begin + MarkClientCorruptablePhase; {!!.04} + HBuildPrevPage ( 1, Moved, True, 0, Dummy ); + If StatusOK Then Begin + If OtherAction Then Begin + InvalidateBrowserScreen; {!!.03b} + End Else Begin + If Moved = 1 Then Begin + If FullPage <> 1 Then Begin + If ClientPosCorrupted Then Begin {!!.04} + InvalidateBrowserScreen; {!!.04} + End Else Begin {!!.04} + GetRowAreaRect ( R ); {!!.04} + Dec (R.Bottom, FontDescr.ChHeightExtra); {!!.04} + CopyRowRec ( BSAPtr^ [1]^, TRR ); + CopyRowRec ( BSAPtr^ [2]^, BSAPtr^ [1]^ ); + DisplayRow ( 1, 0, False); + CopyRowRec ( TRR, BSAPtr^ [1]^ ); + {-Copy RowRec to avoid scrolling the highlight bar} + ScrollWindow ( HWindow, 0, TotalCharHeight, @R, @R ); + {!!.03b} + ValidateRect ( HWindow, Nil ); {!!.03b} + End; {!!.04} + End; + DisplayRow ( 1, 0, True); + End Else Begin + Update := False; + End; + End; + End Else Begin + Update := False; + End; + End Else Begin + DisplayRow ( CR , 0, False); + SetCurRow ( Pred (CR) ); + lwNoPaintHFCg := True; {!!.05} + DisplayRow ( GetCurRow, 0, True); + End; + End; + If Update Then lwUpdateVertScrollBar; + End; + + + Procedure TBrowserWindow.PageDown; + + Var + BST : BrowScreenState; + Moved : Word; + Update, + Changed : Boolean; + + Begin + Update := False; + With BrowserPtr^ Do Begin + GetBrowScreenState ( BST ); + HBuildNextPage ( FullPage, Moved, True, 1, Changed ); + If StatusOK Then Begin + If OtherAction Or (Moved > 0) Or Changed + Or BrowScreenStateChanged ( BST ) Then Begin + InvalidateBrowserScreen; {!!.03b} + Update := True; + End; + End; + End; + lwNoPaintHFCg := True; {!!.05} + If Update Then lwUpdateVertScrollBar; + End; + + + Procedure TBrowserWindow.PageUp; + + Var + BST : BrowScreenState; + Moved : Word; + Update, + Changed : Boolean; + + Begin + Update := False; + With BrowserPtr^ Do Begin + GetBrowScreenState ( BST ); + HBuildPrevPage ( FullPage, Moved, True, 1, Changed ); + If StatusOK Then Begin + If OtherAction Or (Moved > 0) Or Changed + Or BrowScreenStateChanged ( BST ) Then Begin + InvalidateBrowserScreen; {!!.03b} + Update := True; + End; + End; + End; + lwNoPaintHFCg := True; {!!.05} + If Update Then lwUpdateVertScrollBar; + End; + + + Procedure TBrowserWindow.FirstPage; + + Var + BST : BrowScreenState; + Update, + Changed : Boolean; + + Begin + Update := False; + With BrowserPtr^ Do Begin + GetBrowScreenState ( BST ); + HBuildFirstPage ( Changed ); + If StatusOK Then Begin + If Changed Or BrowScreenStateChanged ( BST ) Then Begin + InvalidateBrowserScreen; {!!.03b} + Update := True; + End; + End; + End; + If Update Then lwUpdateVertScrollBar; + End; + + + Procedure TBrowserWindow.LastPage; + + Var + BST : BrowScreenState; + Update, + Changed : Boolean; + + Begin + Update := False; + With BrowserPtr^ Do Begin + GetBrowScreenState ( BST ); + HBuildLastPage ( Changed ); + If StatusOK Then Begin + If Changed Or BrowScreenStateChanged ( BST ) Then Begin + InvalidateBrowserScreen; {!!.03b} + Update := True; + End; + End; + End; + If Update Then lwUpdateVertScrollBar; + End; + + + Procedure TBrowserWindow.MoveToRelPos ( Pos : Word ); + + Var + Key : GenKeyStr; + Ref : LongInt; + + Begin + lwNoPaintHFCg := True; {!!.05} + BrowserPtr^.HGetApprKeyAndRef ( Pos, lwVertScale, Key, Ref ); + SetAndUpdateBrowserScreen ( Key, Ref ); {!!.03b} + lwNoPaintHFCg := True; {!!.05} + End; + + + Procedure TBrowserWindow.LineRight; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := HorizOfs; + HorizOfs := AdjustHorizOfs ( FontDescr.ChWidth ); + If OldHOfs <> HorizOfs Then Begin + InvalidateBrowserScreen; {!!.03b} + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserWindow.LineLeft; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := HorizOfs; + HorizOfs := AdjustHorizOfs ( -FontDescr.ChWidth ); + If OldHOfs <> HorizOfs Then Begin + InvalidateBrowserScreen; {!!.03b} + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserWindow.PageRight; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := HorizOfs; + HorizOfs := AdjustHorizOfs ( FontDescr.ChWidth * 10 ); + If OldHOfs <> HorizOfs Then Begin + InvalidateBrowserScreen; {!!.03b} + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserWindow.PageLeft; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := HorizOfs; + HorizOfs := AdjustHorizOfs ( -FontDescr.ChWidth * 10 ); + If OldHOfs <> HorizOfs Then Begin + InvalidateBrowserScreen; {!!.03b} + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserWindow.LeftHome; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := HorizOfs; + HorizOfs := AdjustHorizOfs ( -HorizOfs ); {!!.03b} + If OldHOfs <> HorizOfs Then Begin + InvalidateBrowserScreen; {!!.03b} + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserWindow.RightHome; + + Var + OldHOfs : Integer; + + Begin + OldHOfs := HorizOfs; + HorizOfs := AdjustHorizOfs ( MaxHorizOfs - HorizOfs ); {!!.03b} + If OldHOfs <> HorizOfs Then Begin + InvalidateBrowserScreen; {!!.03b} + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserWindow.MoveToHorizPos ( Pos : Word ); + + Var + OldHOfs : Integer; + + Begin + OldHOfs := HorizOfs; + HorizOfs := Pos; + HorizOfs := AdjustHorizOfs ( 0 ); + If OldHOfs <> HorizOfs Then Begin + InvalidateBrowserScreen; {!!.03b} + lwUpdateHorzScrollBar; + End; + End; + + + Procedure TBrowserWindow.GetHeaderFooterColor {!!.03} + ( Var Color, BkColor : TColorRef; ForHeader : Boolean ); + + Begin + BkColor := GetSysColor ( Color_HighLight ); + Color := GetSysColor ( Color_HighLightText ); + End; + + + Procedure TBrowserWindow.GetHighlightColor {!!.03} + ( Var Color, BkColor : TColorRef ); + + Begin + BkColor := GetSysColor ( Color_Window ) Xor $FFFFFF; + Color := GetSysColor ( Color_WindowText ) Xor $FFFFFF; + End; + + + Procedure TBrowserWindow.GetNormalColor {!!.03} + ( Var Color, BkColor : TColorRef ); + + Begin + BkColor := GetSysColor ( Color_Window ); + Color := GetSysColor ( Color_WindowText ); + End; + + + Function TBrowserWindow.UseSeparator {!!.03} + ( Var Color : TColorRef ) : Boolean; + + Begin + Color := 0; + UseSeparator := False; + End; + + + Procedure TBrowserWindow.WriteHeader + ( Var HeaderLine : BRLRowEltString; {!!.03b} + DC : HDC ); + Var + SepPos : Word; + SepColor : TColorRef; + + Begin + SepPos := WriteStringOut ( HeaderLine, 0, DC, -HorizOfs ); + If UseSeparator ( SepColor ) Then Begin + DrawSeparator ( SepPos + FontDescr.ChHeight - 1, SepColor, DC ); + {!!.03b} + End; + End; + + + Procedure TBrowserWindow.WriteDataLine + ( Var DataLine : BRLRowEltString; {!!.03b} + LineNr : Word; + DC : HDC; + Inverse : Boolean ); + + Begin + WriteStringOut ( DataLine, LineNr, DC, -HorizOfs ); + End; + + + Procedure TBrowserWindow.WriteFooter + ( Var FooterLine : BRLRowEltString; {!!.03b} + DC : HDC ); + + Var + SepPos : Word; + SepColor : TColorRef; + + Begin + SepPos := TBrowserWindow.WriteStringOut ( FooterLine, + Succ (FullPage), DC, 0 ); + If UseSeparator ( SepColor ) Then Begin + DrawSeparator ( SepPos - 1, SepColor, DC ); + End; + End; + + + Procedure TBrowserWindow.DrawSeparator ( Pos : Word; {!!.03b} + Color : TColorRef; + DC : HDC ); + + Var + OldPen, + Pen : HPen; + TR : TRect; + + Begin + Pen := CreatePen ( PS_Solid, 1, Color ); + If Pen <> 0 Then Begin + OldPen := SelectObject ( DC, Pen ); + GetBrowserTextRect ( TR ); {!!.03b} + MoveTo ( DC, TR.Left, Pos ); + LineTo ( DC, TR.Right, Pos ); + DeleteObject ( SelectObject ( DC, OldPen )); + End; + End; + + + Function TBrowserWindow.WriteStringOut ( Var S : String; {!!.03b} + LineNr : Word; + DC : HDC; + XOfs : Integer ) : Word; + + Var + Buffer : Array [Byte] Of Char; + Y : Word; + + Begin + StrPCopy ( @Buffer, S ); + + FillChar ( Buffer [Length ( S )], SizeOf ( Buffer) - Length ( S ), + 32 ); {!!.03b} + Buffer [255] := #0; + + Y := GetTextOutPosY ( LineNr ); {!!.03b} + WriteStringOut := Y; + TextOut ( DC, XOfs + TextMargin.Left, Y, @Buffer, + Pred (SizeOf (Buffer)) ); + {!!.03b} + End; + + + Procedure TBrowserWindow.GetBrowserTextRect ( Var TextRect : TRect ); + {!!.03b} + + Begin + GetClientRect ( HWindow, TextRect ); + Inc ( TextRect.Left, TextMargin.Left ); + Inc ( TextRect.Top, TextMargin.Top ); + Dec ( TextRect.Right, TextMargin.Right ); + If TextRect.Right < TextRect.Left Then Begin + TextRect.Right := TextRect.Left; + End; + Dec ( TextRect.Bottom, TextMargin.Bottom ); + If TextRect.Bottom < TextRect.Bottom Then Begin + TextRect.Bottom := TextRect.Bottom; + End; + End; + + + Procedure TBrowserWindow.GetRowAreaRect ( Var Rect : TRect ); + + Var + Lines : Word; + + Begin + Rect.Top := GetTextOutPosY ( 1 ); {!!.04mod} + If BrowserPtr <> Nil Then Begin + Lines := BrowserPtr^.GetLastRow; + End Else Begin + Lines := FullPage; + End; + Rect.Bottom := Rect.Top + TotalCharHeight * Lines; + Rect.Left := TextMargin.Left; + Rect.Right := Rect.Left + Width; + End; + + + Function TBrowserWindow.GetTextOutPosY ( LineNr : Word ) : Integer; + + Var + Pos : Integer; + TR : TRect; + + Begin + Pos := (LineNr + FirstRow - 2) * TotalCharHeight {!!.05mod} + + TextMargin.Top; + If LineNr > FullPage Then Begin {!!.05} + GetClientRect ( HWindow, TR ); {!!.05} + Pos := TR.Bottom - TotalCharHeight - FontDescr.ChHeightExtra {!!.05} + - TextMargin.Bottom; {!!.05} + End; {!!.05} + GetTextOutPosY := Pos; {!!.05} + End; + + + Function TBrowserWindow.GetLineNrFromY ( Y : Integer ) : Word; {!!.03b} + + Begin + GetLineNrFromY := (Y - TextMargin.Top) Div TotalCharHeight + + 2 - FirstRow; + End; + + + Function TBrowserWindow.XYPosInRect ( X, Y : Integer; Rect : TRect ) + : Boolean; + + Begin + XYPosInRect := (X >= Rect.Left) And (X < Rect.Right) + And (Y >= Rect.Top) And (Y < Rect.Bottom); + End; + + + Function TBrowserWindow.TotalSpaceForLines ( Rect : TRect ) : Word; + {!!.03b} + Begin + TotalSpaceForLines := Rect.Bottom - Rect.Top; + End; + + + Procedure TBrowserWindow.FillClientGaps ( DC : HDC ); {!!.05} + + Var + HBR : HBrush; + R : TRect; + BkColor, + TextColor : TColorRef; + + Begin + GetBrowserTextRect ( R ); + GetNormalColor ( TextColor, BkColor ); + R.Top := GetTextOutPosY ( FullPage ) + TotalCharHeight + - FontDescr.ChHeightExtra; + HBR := CreateSolidBrush ( BkColor ); + If lwFooter <> '' Then Begin + R.Bottom := GetTextOutPosY ( Succ (FullPage) ); + End; + If HBR <> 0 Then Begin + FillRect ( DC, R, HBR ); + DeleteObject ( HBR ); + End; + End; + + + Procedure TBrowserWindow.DisplayRow ( I : Integer; {!!.03} + DC : HDC; + Inverse : Boolean); + + Var + UsedDC : HDC; + BkColor : TColorRef; + TextColor : TColorRef; + OldBkColor : TColorRef; + OldTextColor : TColorRef; + RG : HRgn; + R : TRect; + + Begin + UsedDC := DC; + If DC = 0 Then Begin + UsedDC := GetDC ( HWindow ); + GetBrowserTextRect ( R ); {!!.03b} + RG := CreateRectRgn ( R.Left, R.Top, R.Right, R.Bottom ); {!!.03b} + SelectClipRgn ( UsedDC, RG ); {!!.03b} + DeleteObject ( RG ); {!!.03b} + End; + + If FontDescr.Font > 0 Then SelectObject ( UsedDC, FontDescr.Font); + + OldBkColor := GetBkColor ( UsedDC ); + OldTextColor := GetTextColor ( UsedDC ); + + If Inverse Then Begin {!!.05mov} + GetHighLightColor ( TextColor, BkColor ); {!!.05mov} + End Else Begin {!!.05mov} + GetNormalColor ( TextColor, BkColor ); {!!.05mov} + End; {!!.05mov} + + SetBkColor ( UsedDC, BkColor ); {!!.05mov} + SetTextColor ( UsedDC, TextColor ); {!!.05mov} + + WriteDataLine ( BrowserPtr^.BSAPtr^ [I]^.Row, I, UsedDC, Inverse ); + {!!.05mov} + If I = 1 Then Begin + If ClientPosCorrupted Or Not lwNoPaintHFCg Then Begin {!!.05mod} + MarkClientCorruptablePhase; {!!.05} + FillClientGaps ( UsedDC ); + If (lwHeader <> '') Or (lwFooter <> '') Then Begin + If lwHeader <> '' Then Begin + GetHeaderFooterColor ( TextColor, BkColor, True ); + SetBkColor ( UsedDC, BkColor ); + SetTextColor ( UsedDC, TextColor ); + WriteHeader ( lwHeader, UsedDC ); + End; + If lwFooter <> '' Then Begin + GetHeaderFooterColor ( TextColor, BkColor, False ); + SetBkColor ( UsedDC, BkColor ); + SetTextColor ( UsedDC, TextColor ); + WriteFooter ( lwFooter, UsedDC ); + End; + End; + SetBkColor ( UsedDC, OldBkColor ); + SetTextColor ( UsedDC, OldTextColor ); + End Else Begin {!!.05} + If BrowserPtr^.GetCurRow <> 1 Then lwNoPaintHFCg := False; {!!.05} + End; + End; + + SetBkColor ( UsedDC, OldBkColor ); + SetTextColor ( UsedDC, OldTextColor ); + + If DC = 0 Then ReleaseDC ( HWindow, UsedDC ); + End; + + + Procedure TBrowserWindow.Paint ( PaintDC : HDC; + Var PaintStruct: TPaintStruct ); + Var + I, + CR : Word; + RG : HRgn; + R : TRect; + DC : HDC; + + Begin + DC := GetDC ( HWindow ); {!!.03b} + GetBrowserTextRect ( R ); {!!.03b} + RG := CreateRectRgn ( R.Left, R.Top, R.Right, R.Bottom ); {!!.03b} + SelectClipRgn ( DC, RG ); {!!.03b} + DeleteObject ( RG ); {!!.03b} + CR := BrowserPtr^.GetCurRow; + For I := 1 To FullPage Do Begin + DisplayRow ( I, DC, I = CR); {!!.03b} + End; + ReleaseDC ( HWindow, DC ); {!!.03b} + End; + + + Procedure TBrowserWindow.WMLButtonDown ( Var Msg : TMessage ); + + Var + X, Y : Word; + OldCurrow : Integer; + Rect : TRect; + + Begin + If Not CanCallLowBrowser Then Begin + Exit; + End; + If Not lwDoMouseMove Then Exit; {!!.03b} + X := Msg.lParam And $FFFF; {!!.03b} + Y := Msg.lParam Shr 16; + OldCurrow := BrowserPtr^.GetCurrow; + If OldCurRow <> 0 Then Begin + GetRowAreaRect ( Rect ); {!!.03b} + If Not XYPosInRect ( X, Y, Rect ) Then Exit; {!!.03b} + BrowserPtr^.SetCurRow ( GetLineNrFromY ( Y ) ); {!!.03b} + If (OldCurRow <> BrowserPtr^.GetCurRow) + And (BrowserPtr^.GetCurRow <> 0) Then Begin + DisplayRow ( OldCurRow, 0, False ); + DisplayRow ( BrowserPtr^.GetCurRow, 0, True ); + lwUpDateVertScrollBar; + End; + End; + End; + + + Procedure TBrowserWindow.WMKillFocus ( Var Msg : TMessage); {!!.03b} + + Begin + lwDoMouseMove := False; + lwCtrlDown := False; + lwShiftDown := False; + lwNoPaintHFCg := False; {!!.50} + DefWndProc ( Msg ); + End; + + + Procedure TBrowserWindow.lwFirstInit; + + Begin + If lwFInitDone Then Exit; + If HWindow = 0 Then Exit; + SetTheFont; + SetMargins; + Reinit; + BrowserPtr^.SetNrOfRows ( FullPage ); + lwThumbHTrack := $FFFF; {!!.03b} + If Attr.Style And ws_HScroll <> 0 Then Begin {!!.03} + SetScrollRange ( HWindow, SB_Horz, 0, MaxHorizOfs, True ); + End; + If Attr.Style And ws_VScroll <> 0 Then Begin {!!.03} + SetScrollRange ( HWindow, SB_Vert, 0, lwVertScale, True ); + End; + lwFInitDone := True; + FirstUserInit; + End; + + + Procedure TBrowserWindow.lwSetAndUpdateBrowserScreen + ( NewKeyStr : GenKeyStr; + NewRef : LongInt ); + + Begin + With BrowserPtr^ Do Begin + HBuildNewPage ( KeyNr, NewKeyStr, NewRef, GetCurRow, NrOfRows ); + InvalidateBrowserScreen; {!!.03b} + If StatusOK Then lwUpdateVertScrollBar; + End; + End; + + + Procedure TBrowserWindow.lwUpdateBrowserScreen; + + Var + Changed : Boolean; + + Begin + With BrowserPtr^ Do Begin + HBuildThisPage ( Changed ); + If Changed Then Begin + InvalidateBrowserScreen; {!!.03b} + If StatusOK Then lwUpdateVertScrollBar; + End; + End; + End; + + + Procedure TBrowserWindow.lwNewSize; + + Var + OldNrOfRows : Word; + + Begin + OldNrOfRows := FullPage; + Reinit; + With BrowserPtr^ Do Begin + If OldNrOfRows > FullPage Then Begin + HShrinkPage ( FullPage ); + End Else Begin + If OldNrOfRows < FullPage Then Begin + HExpandPage ( FullPage ); + End; + End; + End; + InvalidateBrowserScreen; {!!.03b} + End; + + + + Function TBrowserWindow.ConnectLowBrowser + ( ABrowserPtr : PLowWinBrowser; + AHeader, + AFooter : BRLRowEltString ) : Boolean; + + Begin + ConnectLowBrowser := False; + lwFInitDone := False; + If ABrowserPtr = Nil Then Exit; + If BrowserPtr <> Nil Then Begin + If BrowserPtr^.OnHeap Then Begin + Dispose ( BrowserPtr, Done ); + End Else Begin + BrowserPtr^.Done; + End; + End; + BrowserPtr := ABrowserPtr; + BrowserPtr^.Owner := @Self; + SetHeaderNoUpdate ( AHeader ); {!!.03b} + SetFooterNoUpdate ( AFooter ); {!!.03b} + lwFirstInit; + ConnectLowBrowser := True; + End; + + + Function TBrowserWindow.GetClassName : PChar; + + Begin + GetClassName := 'BTreeBrowser'; + End; + + + Procedure TBrowserWindow.GetWindowClass ( Var WndClass : TWndClass ); + + Begin + TWindow.GetWindowClass ( WndClass ); + WndClass.Style := WndClass.Style Or cs_DblClks; + End; + + + Procedure TBrowserWindow.NewSize; + + + Begin + If CanCallLowBrowser Then Begin + lwNewSize; + End; + End; + + + Procedure TBrowserWindow.WMSize ( Var Msg: TMessage ); + + + Begin + If CanCallLowBrowser Then Begin + If Msg.wParam <> SizeIconic Then Begin + NewSize; + End; + End; + TWindow.WMSize ( Msg ); + End; + + + Procedure TBrowserWindow.WMTimer ( Var Msg : TMessage ); + + Begin + If Not CanCallLowBrowser Or lwSupprTimer + Or IsIconic ( HWindow ) Then Exit; + If BrowserPtr^.BrowserCallAllowed Then Begin + UpdateBrowserScreen; + End; + End; + + + Procedure TBrowserWindow.WMNCMouseMove ( Var Msg : TMessage ); {!!.03b} + + Begin + If Not lwDoMouseMove Then Begin + If GetFocus = HWindow Then lwDoMouseMove := True; + End; + DefWndProc ( Msg ); + End; + + + Procedure TBrowserWindow.WMMouseMove ( Var Msg : TMessage ); + + Var + X, Y : Word; + OldCurRow : Integer; + Rect : TRect; + + Begin + If Not lwDoMouseMove Then Begin {!!.03b} + If GetFocus = HWindow Then lwDoMouseMove := True; {!!.03b} + Exit; {!!.03b} + End; {!!.03b} + If CanCallLowBrowser Then Begin + If Msg.wParam = MK_LButton Then Begin + With BrowserPtr^ Do Begin + X := Msg.lParam And $FFFF; {!!.03b} + Y := Msg.lParam Shr 16; + OldCurRow := GetCurRow; + If OldCurRow <> 0 Then Begin + GetRowAreaRect ( Rect ); {!!.03b} + If Not XYPosInRect ( X, Y, Rect ) Then Exit; {!!.03b} + SetCurRow ( GetLineNrFromY ( Y ) ); {!!.03b} + If GetCurRow > GetLastRow Then Begin + SetCurRow ( GetLastRow ); + End; + If (OldCurRow <> GetCurRow) And (GetCurRow <> 0) Then Begin + lwNoPaintHFCg := True; {!!.05} + DisplayRow ( OldCurRow, 0, False ); + lwNoPaintHFCg := True; {!!.05} + DisplayRow ( CurRow, 0, True ); + lwUpdateVertScrollBar; + End; + End; + End; + End; + End; + End; + + + Procedure TBrowserWindow.WMVScroll ( Var Msg : TMessage ); + + Begin + If Not CanCallLowBrowser Then Begin + Exit; + End; + If Not lwDoMouseMove Then Begin {!!.03b} + If GetFocus = HWindow Then lwDoMouseMove := True; {!!.03b} + Exit; {!!.03b} + End; {!!.03b} + Case Msg.wParam Of + SB_EndScroll : Begin + If lwThumbVTrack <> $FFFF Then Begin {!!.03b} + MoveToRelPos ( lwThumbVTrack ); + lwThumbVTrack := $FFFF; {!!.03b} + End; + End; + SB_ThumbTrack : Begin + lwThumbVTrack := Msg.lParam And $0000FFFF; + End; + SB_LineDown : Begin + LineDown; + End; + SB_LineUp : Begin + LineUp; + End; + SB_PageDown : Begin + PageDown; + End; + SB_PageUp : Begin + PageUp; + End; + SB_Top : Begin + FirstPage; + End; + SB_Bottom : Begin + LastPage; + End; + End; {Case} + End; + + + Procedure TBrowserWindow.WMHScroll ( Var Msg : TMessage ); + + Begin + If Not CanCallLowBrowser Then Exit; + If Not lwDoMouseMove Then Begin {!!.03b} + If GetFocus = HWindow Then lwDoMouseMove := True; {!!.03b} + Exit; {!!.03b} + End; {!!.03b} + Case Msg.wParam Of + SB_EndScroll : Begin + If lwThumbHTrack <> $FFFF Then Begin {!!.03b} + MoveToHorizPos ( lwThumbHTrack ); + lwThumbHTrack := $FFFF; {!!.03b} + End; + End; + SB_ThumbTrack : Begin + lwThumbHTrack := Msg.lParam And $0000FFFF; + End; + SB_LineDown : Begin + LineRight; + End; + SB_LineUp : Begin + LineLeft; + End; + SB_PageDown : Begin + PageRight; + End; + SB_PageUp : Begin + PageLeft; + End; + SB_Top : Begin + LeftHome; + End; + SB_Bottom : Begin + RightHome; + End; + End; {Case} + End; + + + Procedure TBrowserWindow.WMKeyDown ( Var Msg : TMessage ); + + Begin + If CanCallLowBrowser Then Begin + Case Msg.wParam Of + vk_Down : Begin + LineDown; + End; + vk_Up : Begin + LineUp; + End; + vk_Next : Begin + If Not lwCtrlDown Then Begin + PageDown; + End; + End; + vk_Prior : Begin + If Not lwCtrlDown Then Begin + PageUp; + End; + End; + vk_Home : Begin + If lwCtrlDown Then Begin + FirstPage; + End Else Begin + LeftHome; + End; + End; + vk_End : Begin + If lwCtrlDown Then Begin + LastPage; + End Else Begin + RightHome; + End; + End; + vk_Right : Begin + If lwCtrlDown Then Begin + PageRight; + End Else Begin + LineRight; + End; + End; + vk_Left : Begin + If lwCtrlDown Then Begin + PageLeft; + End Else Begin + LineLeft; + End; + End; + vk_Control : Begin + lwCtrlDown := True; + End; + vk_Menu : Begin + lwCtrlDown := False; + End; + vk_Shift : Begin + lwShiftDown := True; + End; + End; + End; + DefWndProc( Msg ); + End; + + + Procedure TBrowserWindow.WMKeyUp ( Var Msg : TMessage ); + + Begin + Case Msg.wParam Of + vk_Control : Begin + lwCtrlDown := False; + End; + vk_Shift : Begin + lwShiftDown := False; + End; + End; + DefWndProc ( Msg ); + End; + + + Procedure TBrowserWindow.WMChar ( Var Msg : TMessage ); + + Begin + If Not CanCallLowBrowser Then Begin + DefWndProc ( Msg ); + Exit; + End; + + If HandleChar ( Msg ) Then Exit; + + Case UpCase ( Chr (Msg.wParam )) Of + '0'..'9', 'A'..'Z', '', '', '', '', '', '', '' : Begin + SetAndUpdateBrowserScreen ( Chr (Msg.wParam ), 0 ); {!!.03b} + End; + '+' : Begin + UpdateBrowserScreen; {!!.03b} + End Else + DefWndproc ( Msg ); + End; {Case} + End; + + +{$IFDEF InitAllUnits} +Begin +{$ENDIF} +End. diff --git a/src/wc_sdk/wcdb.pas b/src/wc_sdk/wcdb.pas new file mode 100755 index 0000000..4cc968d --- /dev/null +++ b/src/wc_sdk/wcdb.pas @@ -0,0 +1,694 @@ +{$IFDEF FPC}{$I-}{$V-}{$ENDIF} +unit WcDb; + +interface + +uses + Crt, + WcMisc, + NumKeys, + IsamTool, + Desq, + Filer, + BTISBase, + VRec; + +const + MaxLockRetries = 50; + +type + PFileBlock = ^TFileBlock; + TFileBlock = object + IFBPtr : IsamFileBlockPtr; + LockCount : Integer; + Retries : Integer; + UniqueKey : Integer; + MaxDataLen : Word; + CoverBuffer : Pointer; + + constructor Init(FName : IsamFileBlockName; Save, Net : Boolean; + AUniqueKey : Integer; AMaxDataLen : Word); + destructor Done; virtual; + procedure GetCreateInfo(var Len : Word; var Keys : Integer; var IID : IsamIndDescr); virtual; + procedure PostCreate; virtual; + function LockOkay(const What : String) : Boolean; + procedure Lock; + procedure Unlock; + function BuildKey(const Data; Key : Integer) : IsamKeyStr; virtual; + procedure GetRec(RefNr : LongInt; var Data); virtual; + procedure AddRec(var RefNr : LongInt; var Data); virtual; + procedure PutRec(RefNr : LongInt; var Data); virtual; + procedure DelRec(RefNr : LongInt); virtual; + procedure AddKey(KeyNr : Integer; RefNr : LongInt; Key : IsamKeyStr); + procedure DeleteKey(KeyNr : Integer; RefNr : LongInt; Key : IsamKeyStr); + procedure DeleteAllKeys(KeyNr : Integer); + function FindKey(KeyNr : Integer; var RefNr : LongInt; Key : IsamKeyStr) : Boolean; + function RecLen : Word; + function FileLen : LongInt; + function FreeRecs : LongInt; + function UsedRecs : LongInt; + function UsedKeys(KeyNr : Integer) : LongInt; + procedure ClearKey(KeyNr : Integer); + function NextKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr) : Boolean; + procedure NextDiffKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr); + function PrevKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr) : Boolean; + procedure PrevDiffKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr); + procedure SearchKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr); + function KeyExists(KeyNr : Integer; RefNr : LongInt; Key : IsamKeyStr) : Boolean; + function AddRecord(var RefNr : LongInt; var Data) : Boolean; virtual; + procedure PutRecordPrim(RefNr : LongInt; var OldData, NewData); virtual; + function UpdateRecord(var OldData, NewData) : Boolean; + function UpdateRecordKey(const Key : IsamKeyStr; var NewData) : Boolean; + function DeleteRecordPrim(RefNr : LongInt; var Data): Boolean; virtual; + function DeleteRecord(var Data) : Boolean; + function DeleteRecordKey(const Key : IsamKeyStr) : Boolean; + procedure SearchKeyAndRef(KeyNr : Integer; var RefNr : LongInt; Key : IsamKeyStr); + procedure FindKeyAndRef(KeyNr : Integer; var RefNr : LongInt; Key : IsamKeyStr; SVal : Integer); + procedure FatalDBError(const S : String); virtual; + procedure LogDBError(const S : String); virtual; + end; + + PVFileBlock = ^TVFileBlock; + TVFileBlock = object(TFileBlock) + function DataLen(const Data) : Word; virtual; + procedure GetRec(RefNr : LongInt; var Data); virtual; + procedure AddRec(var RefNr : LongInt; var Data); virtual; + procedure PutRec(RefNr : LongInt; var Data); virtual; + procedure DelRec(RefNr : LongInt); virtual; + procedure GetRecPart(RefNr : LongInt; var Data; Len : Word); + procedure GetFixedRec(RefNr : LongInt; var Data); + procedure AddFixedRec(var RefNr : LongInt; var Data); + procedure DelFixedRec(RefNr : LongInt); + procedure PutFixedRec(RefNr : LongInt; var Data); + end; + +function Word2Key(Num : Word) : IsamKeyStr; +function Long2Key(Num : LongInt) : IsamKeyStr; +function Key2Long(const Key : IsamKeyStr) : LongInt; +procedure LogFatalError(const S : String; ErrorCode : Word); +procedure LogError(const S : String; ErrorCode : Word); + +implementation + +uses + WcGlobal; + + function Word2Key(Num : Word) : IsamKeyStr; + begin + Word2Key := CStyleNumKey(WordToKey(Num)); + end; + + + function Long2Key(Num : LongInt) : IsamKeyStr; + begin + Long2Key := CStyleNumKey(LongToKey(Num)); + end; + + + function Key2Long(const Key : IsamKeyStr) : LongInt; + begin + Key2Long := KeyToLong(PascalStyleNumKey(Key)); + end; + + + procedure LogFatalError(const S : String; ErrorCode : Word); + begin + LogError(S, ErrorCode); + end; + + + procedure LogError(const S : String; ErrorCode : Word); + begin + writeln(S+' :'+Long2Str(ErrorCode)); + {writeln instead of noteerror} + end; + + + procedure Abstract; + begin + RunError(211); + end; + + + constructor TFileBlock.Init(FName : IsamFileBlockName; Save, Net : Boolean; + AUniqueKey : Integer; AMaxDataLen : Word); + var + Keys : Integer; + IID : IsamIndDescr; + DataLen : Word; + Created : Boolean; + + begin + LockCount := 0; + Retries := 0; + CoverBuffer := nil; + UniqueKey := AUniqueKey; + MaxDataLen := AMaxDataLen; + if not ExistFile(FName+'.DAT') then + begin + GetCreateInfo(DataLen, Keys, IID); + BtCreateFileBlock(FName, DataLen, Keys, IID); + + if not IsamOk then + Fail; + Created := True; + end else + Created := False; + + repeat + BtOpenFileBlock(IFBPtr, FName, False, False, Save, Net); + until LockOkay('open'); + + if Created then + PostCreate; + end; + + + procedure TFileBlock.GetCreateInfo(var Len : Word; var Keys : Integer; var IID : IsamIndDescr); + begin + Abstract; + end; + + + procedure TFileBlock.PostCreate; + begin + end; + + + destructor TFileBlock.Done; + begin + repeat + BtCloseFileBlock(IFBPtr); + until LockOkay('close'); + end; + + + function TFileBlock.LockOkay(const what : String) : Boolean; + begin + LockOkay := True; + if not IsamOk then + begin + case BtIsamErrorClass of + 1 : {ignore}; + 2 : if Retries < MaxLockRetries then + begin + LockOkay := False; + WriteTopRight('Lock retry #'+Long2Str(Retries)); + Inc(Retries); + WcDelay(500 + Random(500)); + end + else + FatalDBError('Unable lock database after 50 retries!'); + 3, + 4 : FatalDBError('Unable to '+what+' database!'); + end; + end + else + begin + if Retries > 0 then + WriteTopRight(' '); + Retries := 0; + end; + end; + + procedure TFileBlock.Lock; + begin + if LockCount = 0 then + repeat + BtLockFileBlock(IFBPtr); + until LockOkay('lock'); + Inc(LockCount); + end; + + + procedure TFileBlock.Unlock; + begin + Dec(LockCount); + if LockCount = 0 then + repeat + BtUnLockFileBlock(IFBPtr); + until LockOkay('unlock'); + end; + + + function TFileBlock.BuildKey(const Data; Key : Integer) : IsamKeyStr; + begin + Abstract; + end; + + + procedure TFileBlock.GetRec(RefNr : LongInt; var Data); + begin + repeat + BtGetRec(IFBPtr, RefNr, Data, False); + until LockOkay('read'); + end; + + + procedure TFileBlock.AddRec(var RefNr : LongInt; var Data); + begin + repeat + BtAddRec(IFBPtr, RefNr, Data); + until LockOkay('write'); + end; + + + procedure TFileBlock.PutRec(RefNr : LongInt; var Data); + begin + repeat + BtPutRec(IFBPtr, RefNr, Data, False); + until LockOkay('write'); + end; + + + procedure TFileBlock.DelRec(RefNr : LongInt); + begin + repeat + BtDeleteRec(IFBPtr, RefNr); + until LockOkay('write'); + end; + + + procedure TFileBlock.AddKey(KeyNr : Integer; RefNr : LongInt; Key : IsamKeyStr); + begin + repeat + BtAddKey(IFBPtr, KeyNr, RefNr, Key); + until LockOkay('write'); + end; + + + procedure TFileBlock.DeleteKey(KeyNr : Integer; RefNr : LongInt; Key : IsamKeyStr); + + begin + repeat + BtDeleteKey(IFBPtr, KeyNr, RefNr, Key); + until LockOkay('write'); + end; + + + function TFileBlock.FindKey(KeyNr : Integer; var RefNr : LongInt; Key : IsamKeyStr) : Boolean; + begin + repeat + BtFindKey(IFBPtr, KeyNr, RefNr, Key); + until LockOkay('write'); + FindKey := IsamOk; + end; + + + function TFileBlock.RecLen : Word; + begin + RecLen := BtDatRecordSize(IFBPtr); + end; + + + function TFileBlock.FileLen : LongInt; + begin + repeat + FileLen := BtFileLen(IFBPtr); + until LockOkay('read'); + end; + + + function TFileBlock.FreeRecs : LongInt; + begin + repeat + FreeRecs := BtFreeRecs(IFBPtr); + until LockOkay('read'); + end; + + + function TFileBlock.UsedRecs : LongInt; + begin + repeat + UsedRecs := BtUsedRecs(IFBPtr); + until LockOkay('read'); + end; + + + function TFileBlock.UsedKeys(KeyNr : Integer) : LongInt; + begin + repeat + UsedKeys := BtUsedKeys(IFBPtr, KeyNr); + until LockOkay('read'); + end; + + + procedure TFileBlock.ClearKey(KeyNr : Integer); + begin + repeat + BtClearKey(IFBPtr, KeyNr); + until LockOkay('read'); + end; + + + function TFileBlock.NextKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr) : Boolean; + begin + repeat + BtNextKey(IFBPtr, KeyNr, RefNr, Key); + until LockOkay('read'); + NextKey := IsamOk; + end; + + + procedure TFileBlock.NextDiffKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr); + begin + repeat + BtNextDiffKey(IFBPtr, KeyNr, RefNr, Key); + until LockOkay('read'); + end; + + + function TFileBlock.PrevKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr) : Boolean; + begin + repeat + BtPrevKey(IFBPtr, KeyNr, RefNr, Key); + until LockOkay('read'); + PrevKey := IsamOk; + end; + + + procedure TFileBlock.PrevDiffKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr); + begin + repeat + BtPrevDiffKey(IFBPtr, KeyNr, RefNr, Key); + until LockOkay('read'); + end; + + + procedure TFileBlock.SearchKey(KeyNr : Integer; var RefNr : LongInt; var Key : IsamKeyStr); + begin + repeat + BtSearchKey(IFBPtr, KeyNr, RefNr, Key); + until LockOkay('read'); + end; + + + function TFileBlock.KeyExists(KeyNr : Integer; RefNr : LongInt; Key : IsamKeyStr) : Boolean; + begin + repeat + KeyExists := BtKeyExists(IFBPtr, KeyNr, RefNr, Key); + until LockOkay('read'); + end; + + + procedure TFileBlock.SearchKeyAndRef(KeyNr : Integer; var RefNr : LongInt; Key : IsamKeyStr); + begin + repeat + BTSearchKeyAndRef(IFBPtr, KeyNr, RefNr, Key); + until LockOkay('read'); + end; + + + procedure TFileBlock.FindKeyAndRef(KeyNr : Integer; var RefNr : LongInt; Key : IsamKeyStr; SVal : Integer); + begin + repeat + BTFindKeyAndRef(IFBPtr, KeyNr, RefNr, Key, SVal); + until LockOkay('read'); + end; + + + function TFileBlock.AddRecord(var RefNr : LongInt; var Data) : Boolean; + var + I : Byte; + Key : IsamKeyStr; + + begin + Lock; + if FindKey(UniqueKey, RefNr, BuildKey(Data, UniqueKey)) then + begin + { record already in database } + + Unlock; + AddRecord := False; + Exit; + end; + AddRec(RefNr, Data); + if not IsamOk then + FatalDBError('Unable to add record to database!'); + + for I := 1 to IFBPtr^.NrOfKeys do + begin + Key := BuildKey(data, I); + if Key <> '' then + begin + AddKey(I, RefNr, Key); + if not IsamOk then + FatalDBError('Unable to add key to index!'); + end; + end; + Unlock; + + AddRecord := True; + end; + + + procedure TFileBlock.PutRecordPrim(RefNr : LongInt; var OldData, NewData); + var + I : Integer; + Key : IsamKeyStr; + + begin + Lock; + for I := 1 to IFBPtr^.NrOfKeys do + begin + Key := BuildKey(OldData, I); + if (Key <> '') and (Key <> BuildKey(NewData, I)) then + begin + DeleteKey(I, RefNr, Key); + if not IsamOk then + FatalDBError('Unable to delete key!'); + end; + end; + PutRec(RefNr, NewData); + if not IsamOk then + FatalDBError('Unable to delete record!'); + for I := 1 to IFBPtr^.NrOfKeys do + begin + Key := BuildKey(NewData, I); + if (Key <> '') and (Key <> BuildKey(OldData, I)) then + begin + AddKey(I, RefNr, Key); + if not IsamOk then + FatalDBError('Unable to add key to index!'); + end; + end; + Unlock; + end; + + + function TFileBlock.UpdateRecord(var OldData, NewData) : Boolean; + label + ExitPoint; + + var + RefNr, TempRefNr : LongInt; + Key : IsamKeyStr; + + begin + UpdateRecord := False; + Lock; + Key := BuildKey(OldData, UniqueKey); + if FindKey(UniqueKey, RefNr, Key) then + begin + if (BuildKey(NewData, UniqueKey) <> Key) and FindKey(UniqueKey, TempRefNr, BuildKey(NewData, UniqueKey)) then + goto ExitPoint; + GetRec(RefNr, OldData); + if IsamOk then + begin + PutRecordPrim(RefNr, OldData, NewData); + UpdateRecord := True; + end; + end; + ExitPoint: + Unlock; + end; + + + function TFileBlock.UpdateRecordKey(const Key : IsamKeyStr; var NewData) : Boolean; + label + ExitPoint; + + var + RefNr, TempRefNr : LongInt; + OldData : Pointer; + + begin + UpdateRecordKey := False; + if not GetMemCheck(OldData, MaxDataLen) then + Exit; + Lock; + if FindKey(UniqueKey, RefNr, Key) then + begin + if (BuildKey(NewData, UniqueKey) <> Key) and FindKey(UniqueKey, TempRefNr, BuildKey(NewData, UniqueKey)) then + goto ExitPoint; + GetRec(RefNr, OldData^); + if IsamOk then + begin + PutRecordPrim(RefNr, OldData^, NewData); + UpdateRecordKey := True; + end; + end; + ExitPoint: + Unlock; + FreeMemCheck(OldData, MaxDataLen); + end; + + + Function TFileBlock.DeleteRecordPrim(RefNr : LongInt; var Data): Boolean; + + var Key : IsamKeyStr; + I,J : Integer; + + begin + Lock; + for I := 1 to IFBPtr^.NrOfKeys do + begin + Key := BuildKey(Data, I); + if Key <> '' then + begin + DeleteKey(I, RefNr, Key); + if not IsamOk then + {break;} + end; + end; + + DelRec(RefNr); + + DeleteRecordPrim := IsamOk; + + Unlock; + end; + + + function TFileBlock.DeleteRecord(var Data) : Boolean; + var + RefNr : LongInt; + + begin + Lock; + if FindKey(UniqueKey, RefNr, BuildKey(Data, UniqueKey)) then + begin + GetRec(RefNr, Data); + DeleteRecordPrim(RefNr, Data); + DeleteRecord := True; + end + else + DeleteRecord := False; + Unlock; + end; + + + function TFileBlock.DeleteRecordKey(const Key : IsamKeyStr) : Boolean; + var + Data : Pointer; + RefNr : LongInt; + + begin + DeleteRecordKey := False; + if not GetMemCheck(Data, MaxDataLen) then + Exit; + Lock; + if FindKey(UniqueKey, RefNr, Key) then + begin + GetRec(RefNr, Data^); + DeleteRecordPrim(RefNr, Data^); + DeleteRecordKey := True; + end; + Unlock; + FreeMemCheck(Data, MaxDataLen); + end; + + + procedure TFileBlock.DeleteAllKeys(KeyNr : Integer); + begin + Lock; + BtDeleteAllKeys(IFBPtr, KeyNr); + Unlock; + end; + + + procedure TFileBlock.FatalDBError(const S : String); + begin + LogFatalError(S + IsamErrorMessage(IsamError), IsamError); + end; + + + procedure TFileBlock.LogDBError(const S : String); + begin + LogError(S + IsamErrorMessage(IsamError), IsamError); + end; + + + function TVFileBlock.DataLen(const Data) : Word; + begin + Abstract; + end; + + + procedure TVFileBlock.GetRec(RefNr : LongInt; var Data); + var + Len : Word; + + begin + repeat + BtGetVariableRec(IFBPtr, RefNr, Data, Len); + until LockOkay('read'); + end; + + + procedure TVFileBlock.AddRec(var RefNr : LongInt; var Data); + begin + repeat + BtAddVariableRec(IFBPtr, RefNr, Data, DataLen(Data)); + until LockOkay('write'); + end; + + + procedure TVFileBlock.PutRec(RefNr : LongInt; var Data); + begin + repeat + BtPutVariableRec(IFBPtr, RefNr, Data, DataLen(Data)); + until LockOkay('write'); + end; + + + procedure TVFileBlock.DelRec(RefNr : LongInt); + begin + repeat + BtDeleteVariableRec(IFBPtr, RefNr); + until LockOkay('write'); + end; + + + procedure TVFileBlock.GetRecPart(RefNr : LongInt; var Data; Len : Word); + begin + repeat + BtGetVariableRecPart(IFBPtr, RefNr, Data, Len); + until LockOkay('read'); + end; + + + procedure TVFileBlock.GetFixedRec(RefNr : LongInt; var Data); + begin + TFileBlock.GetRec(RefNr, Data); + end; + + + procedure TVFileBlock.AddFixedRec(var RefNr : LongInt; var Data); + begin + TFileBlock.AddRec(RefNr, Data); + end; + + + procedure TVFileBlock.DelFixedRec(RefNr : LongInt); + begin + TFileBlock.DelRec(RefNr); + end; + + + procedure TVFileBlock.PutFixedRec(RefNr : LongInt; var Data); + begin + TFileBlock.PutRec(RefNr, Data); + end; + +end. diff --git a/src/wc_sdk/wcfiledb.pas b/src/wc_sdk/wcfiledb.pas new file mode 100755 index 0000000..69c6ba8 --- /dev/null +++ b/src/wc_sdk/wcfiledb.pas @@ -0,0 +1,457 @@ +unit WcFileDb; + +interface + +uses + Dos, + Desq, + WcType, + Filer, + BTISBase, + QxStub, + QxIndex, + WcDb, + WcMisc, + WcGlobal; + +const + FileAreaKey = 1; + FileNameKey = 2; + FileDateKey = 3; + FileUpKey = 4; + +type + PFileDatabase = ^TFileDatabase; + TFileDatabase = object(TVFileBlock) + IndexDb : TIndexFile; + DataBase : String[8]; + FileCountDelta : LongInt; + constructor Init(const FName : IsamFileBlockName); + destructor Done; virtual; + procedure GetCreateInfo(var Len : Word; var Keys : Integer; var IID : IsamIndDescr); virtual; + function DataLen(const Data) : Word; virtual; + function BuildKey(const Rec; Key : Integer) : IsamKeyStr; virtual; + function AddRecord(var RefNr : LongInt; var Data) : Boolean; virtual; + function DeleteRecord(var Data) : Boolean; virtual; + procedure PutRecordPrim(RefNr : LongInt; var OldData, NewData); virtual; + function UpdateRecordName(Area : Word; const Name : String; var NewData) : Boolean; + procedure UpdateMasterInfo; + procedure FatalDBError(const S : String); virtual; + procedure LogDBError(const S : String); virtual; + end; + +Procedure InitWCfiledb; +Procedure DisposeWCfiledb; +procedure AddIndexRecord(RefNr : LongInt; const Data); +function PackFileArea(Area : Word; const Name : String) : IsamKeyStr; +function PackFileName(const Name : String; Area : Word) : IsamKeyStr; + +var + FileDb : PFileDatabase; + +const + FileDBOpen : Boolean = False; + +implementation + +const + WordChars : set of Char = ['!', '#', '$', '''', '-', '.', '0'..'9', '@', '_']; + StartChars : set of Char = ['!', '#', '$', '0'..'9']; + EndChars : set of Char = ['0'..'9']; + +var + WordCharsWithSlash : set of Char; + +{$IFDEF FPC} + function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean; + begin + LongFlagIsSet := Flags and FlagMask = FlagMask; + end; +{$ELSE} + function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean; + inline($5B/$59/$58/$5A/$21/$D8/$21/$CA/$09/$D0/$74/$02/$B0/$01); +{$ENDIF} + + + function PackFileArea(Area : Word; const Name : String) : IsamKeyStr; + begin + PackFileArea := Word2Key(Area)+StUpcase(Pad(Name, 12)); + end; + + + function PackFileName(const Name : String; Area : Word) : IsamKeyStr; + begin + PackFileName := StUpcase(Pad(Name, 12))+Word2Key(Area); + end; + + + procedure TFileDatabase.GetCreateInfo(var Len : Word; var Keys : Integer; var IID : IsamIndDescr); + begin + Len := 316; + Keys := 4; + IID[1].KeyL := 15; {Area + Filename} + IID[1].AllowDupK := False; + IID[2].KeyL := 15; {Filename + Area} + IID[2].AllowDupK := False; + IID[3].KeyL := 11; {File date} + IID[3].AllowDupK := True; + IID[4].KeyL := 30; {Uploader name + Uploader ID key} + IID[4].AllowDupK := True; + end; + + + constructor TFileDatabase.Init(const FName : IsamFileBlockName); + begin + if not inherited Init(FName, + MwConfig^.DatabaseMode = dbSaveMode, + MwConfig^.Network <> WcType.NoNet, + FileAreaKey, SizeOf(TFileRec)) then + Fail; + + if not IndexDb.Init(ForceExtension(FName, 'QX')) then + begin + inherited Done; + Fail; + end; + DataBase := JustName(FName); + FileDBOpen := True; + FileCountDelta := 0; + end; + + + destructor TFileDatabase.Done; + begin + IndexDb.Done; + inherited Done; + FileDBOpen := False; + UpdateMasterInfo; + end; + + + function TFileDatabase.DataLen(const Data) : Word; + var + FileRec : TFileRec absolute Data; + + begin + DataLen := SizeOf(TFileHeader) + FileRec.MsgBytes; + end; + + + function TFileDatabase.BuildKey(const Rec; Key : Integer) : IsamKeyStr; + var + FileRec : TFileRec absolute Rec; + KeyStr : IsamKeyStr; + + begin + with FileRec do + case Key of + FileAreaKey : BuildKey := PackFileArea(Area, StUpcase(FileName)); + FileNameKey : BuildKey := PackFileName(StUpcase(FileName), Area); + FileDateKey : BuildKey := Word2Key(Area)+Word2Key(FileTime.D)+Long2Key(FileTime.T); + FileUpKey : BuildKey := Pad(StUpcase(Uploader), 25)+Long2key(UploaderID); + end; + end; + + + function AddWords(oldf: PFileRec; P : PChar; Len : Word; RefNr : LongInt) : Boolean; + var + I, OS2I : Word; + Q, T, OS2P, OS2T : PChar; + S : String; + {$IFDEF FPC} + TLen, OS2TLen : PtrUInt; + {$ENDIF} + + begin + AddWords := False; + I := 0; + while I < Len do + begin + while (I < Len) and not (P^ in StartChars) do + begin + Inc(P); + Inc(I); + end; + if I >= Len then + Break; + Q := P; + while (I < Len) and (P^ in WordChars) do + begin + Inc(P); + Inc(I); + end; + T := P; + {$IFDEF FPC} + while (T > Q) and not ((T-1)^ in EndChars) do + {$ELSE} + while (Word(T) > Word(Q)) and not (T[$FFFF] in EndChars) do + {$ENDIF} + Dec(T); + + OS2I := I; + OS2P := P; + while (OS2I < Len) and (OS2P^ in WordCharsWithSlash) do + begin + Inc(OS2P); + Inc(OS2I); + end; + OS2T := OS2P; + {$IFDEF FPC} + while (OS2T > Q) and not ((OS2T-1)^ in EndChars) do + {$ELSE} + while (Word(OS2T) > Word(Q)) and not (OS2T[$FFFF] in EndChars) do + {$ENDIF} + Dec(OS2T); + + {$IFDEF FPC} + TLen := T - Q; + OS2TLen := OS2T - Q; + if TLen > 0 then + begin + Move(Q^, S[1], TLen); + S[0] := Chr(TLen); + {$ELSE} + if Word(T) > Word(Q) then + begin + Move(Q^, S[1], Word(T) - Word(Q)); + S[0] := Chr(Word(T) - Word(Q)); + {$ENDIF} + S := StUpcase(S); + if (oldf = nil) or (SearchUC(oldf^, sizeof(TFileHeader)+oldf^.MsgBytes, s[1], Length(s)) = $FFFF) then + filedb^.IndexDb.Add(S, RefNr); + + {$IFDEF FPC} + if OS2TLen > TLen then + begin + Move(Q^, S[1], OS2TLen); + S[0] := Chr(OS2TLen); + {$ELSE} + if Word(OS2T) > Word(T) then + begin + Move(Q^, S[1], Word(OS2T) - Word(Q)); + S[0] := Chr(Word(OS2T) - Word(Q)); + {$ENDIF} + S := StUpcase(S); + if (oldf = nil) or (SearchUC(oldf^, sizeof(TFileHeader)+oldf^.MsgBytes, s[1], Length(s)) = $FFFF) then + filedb^.IndexDb.Add(S, RefNr); + end; + end; + end; + AddWords := True; + end; + + + function AddWordsStr(oldf: PFileRec; const S : String; RefNr : LongInt): Boolean; + begin + AddWordsStr := AddWords(oldf, @S[1], Length(S), RefNr); + end; + + + procedure AddIndexRecord(RefNr : LongInt; const Data); + var + FileRec : TFileRec absolute Data; + Counter : Byte; + + begin + AddWordsStr(nil, FileRec.FileName, RefNr); + if JustExtension(FileRec.FileName) <> '' then + AddWordsStr(nil, JustExtension(FileRec.FileName), RefNr); + if FileRec.Uploader <> '' then + AddWordsStr(nil, FileRec.Uploader, RefNr); + if FileRec.Desc <> '' then + AddWordsStr(nil, FileRec.Desc, RefNr); + if LongFlagIsSet(MwConfig^.mwFlags, mwIndexLongDesc) and (FileRec.MsgBytes > 0) then + AddWords(nil, @FileRec.MsgText, FileRec.MsgBytes, RefNr); + for Counter := 1 to 6 do + if FileRec.KeyWords[Counter] <> '' then + AddWordsStr(nil, FileRec.KeyWords[Counter], RefNr); + end; + + function TFileDatabase.DeleteRecord(var Data) : Boolean; + begin + Lock; + if inherited DeleteRecord(Data) then + begin + DeleteRecord := IsamOk; + Dec(FileCountDelta); + end + else + DeleteRecord := False; + Unlock; + end; + + + function TFileDatabase.AddRecord(var RefNr : LongInt; var Data) : Boolean; + var + FileRec : TFileRec absolute Data; + + begin + Lock; + if inherited AddRecord(RefNr, Data) then + begin + AddRecord := True; + AddIndexRecord(RefNr, Data); + Inc(FileCountDelta); + end + else + AddRecord := False; + Unlock; + end; + + + procedure UpdateIndexRecord(RefNr : LongInt; var OldRec; var NewRec); + var + Counter : Byte; + OldFile : TFileRec absolute OldRec; + NewFile : TFileRec absolute NewRec; + + begin + if (OldFile.FileName <> NewFile.FileName) then + AddWordsStr(@OldFile, NewFile.FileName, RefNr); + if (OldFile.Uploader <> NewFile.Uploader) and (NewFile.Uploader <> '') then + AddWordsStr(@OldFile, NewFile.Uploader, RefNr); + if (OldFile.Desc <> NewFile.Desc) and (NewFile.Desc <> '') then + AddWordsStr(@OldFile, NewFile.Desc, RefNr); + if LongFlagIsSet(MwConfig^.mwFlags, mwIndexLongDesc) and (NewFile.MsgBytes > 0) then + if (OldFile.MsgBytes <> NewFile.MsgBytes) + or SameStruct(OldFile.MsgText, NewFile.MsgText, OldFile.MsgBytes) then + AddWords(@OldFile, @NewFile.MsgText, NewFile.MsgBytes, RefNr); + for Counter := 1 to 6 do + if (OldFile.Keywords[Counter] <> NewFile.Keywords[Counter]) and (NewFile.KeyWords[Counter] <> '') then + AddWordsStr(@OldFile, NewFile.KeyWords[Counter], RefNr); + end; + + + procedure TFileDatabase.PutRecordPrim(RefNr : LongInt; var OldData, NewData); + var + OldFileRec : TFileRec absolute OldData; + NewFileRec : TFileRec absolute NewData; + + begin + Lock; + UpdateIndexRecord(RefNr, OldData, NewData); + inherited PutRecordPrim(RefNr, OldData, NewData); + Unlock; + end; + + + function TFileDatabase.UpdateRecordName(Area : Word; const Name : String; var NewData) : Boolean; + begin + UpdateRecordName := inherited UpdateRecordKey(PackFileArea(Area, Name), NewData); + end; + + + procedure TFileDatabase.FatalDBError(const S : String); + begin + LogFatalError('FILE DATABASE '+DataBase+' : ' + S, IsamError); + end; + + + procedure TFileDatabase.LogDBError(const S : String); + begin + LogError('FILE DATABASE '+DataBase+' : ' + S, IsamError); + end; + + + procedure TFileDatabase.UpdateMasterInfo; + var + f : file of TMasterInfo; + MI : TMasterInfo; + Io : Word; + MFRetries: Word; + + procedure UnLockNode; + begin + if not BTIsamUnLockRecord(0, SizeOf(TNodeInfo), FileRec(f).Handle) then + FatalDBError('Error unlocking NODEINFO.DAT'); + end; + + begin + Assign(f, MwConfig^.NodeInfoPath + 'NODEINFO.DAT'); + Filemode := $42; + Reset(f); + Io := IoResult; + if Io <> 0 then + begin + FatalDBError('Unable to open NODEINFO.DAT.'); + exit; + end; + + MFRetries := 0; + while not BTIsamLockRecord(0, SizeOf(TMasterInfo), FileRec(f).Handle, IsamLockTimeOut, IsamDelayBetwLocks) do + begin + Inc(MFRetries); + if MFRetries = 50 then + begin + FatalDBError('Unable to lock NODEINFO.DAT.'); + exit; + end; + + WcDelay(5 + Random(10)); + end; + + Read(f, MI); + Io := IoResult; + if Io <> 0 then + begin + UnLockNode; + FatalDBError('Unable to read from NODEINFO.DAT.'); + exit; + end; + + if FileCountDelta+MI.TotalFiles < 0 then + MI.TotalFiles := 0 + else + Inc(MI.TotalFiles, FileCountDelta); + + Seek(f, 0); + Write(f, MI); + UnLockNode; + + Io := IoResult; + if Io <> 0 then + begin + FatalDBError('Unable to write to NODEINFO.DAT.'); + exit; + end; + Close(f); + if IoResult <> 0 then ; + + FileCountDelta := 0; + end; + + + procedure InitWordChars; + var + C : Char; + + begin + for C := #0 to #255 do + if (Upcase(C) <> C) then begin + Include(WordChars, C); + Include(WordChars, Upcase(C)); + Include(StartChars, C); + Include(StartChars, Upcase(C)); + Include(EndChars, C); + Include(EndChars, Upcase(C)); + end; + WordCharsWithSlash := WordChars; + Include(WordCharsWithSlash, '/'); + Include(WordCharsWithSlash, '_'); + end; + +Procedure InitWcFileDb; + + begin + InitWordChars; + new(filedb); + end; + +Procedure DisposeWcFileDb; + + begin + dispose(filedb); + end; + +begin +end. diff --git a/src/wc_sdk/wcglobal.pas b/src/wc_sdk/wcglobal.pas new file mode 100755 index 0000000..1ae0d5a --- /dev/null +++ b/src/wc_sdk/wcglobal.pas @@ -0,0 +1,34 @@ +{$IFDEF FPC}{$I-}{$V-}{$ENDIF} +unit WcGlobal; + +interface + +uses + WcType; + +Procedure InitWCglobal; + +Procedure DisposeWCglobal; + +var + MwConfig : PMakewildRec; {global Makewild record} + NodeInfoFile : File; {global nodeinfo file handle} + MasterInfo : PMasterInfo; {global master info record} + +implementation + +Procedure InitWCglobal; + + begin + new(MwConfig); + new(MasterInfo); + end; + +Procedure DisposeWCglobal; + + begin + dispose(MwConfig); + dispose(MasterInfo); + end; + +end. \ No newline at end of file diff --git a/src/wc_sdk/wcmisc.pas b/src/wc_sdk/wcmisc.pas new file mode 100755 index 0000000..d8c003d --- /dev/null +++ b/src/wc_sdk/wcmisc.pas @@ -0,0 +1,876 @@ +{$IFDEF FPC}{$I-}{$V-}{$ENDIF} +unit WcMisc; + +interface + +uses + Crt, + Dos, + NumKeys, + Filer, + BTISBase, + WcType, + WcGlobal; + +const + NoMoreBits = $FFFF; + +const + ShareMode = $42; + +function Upcase(C : Char) : Char; +function StUpcase(S : String) : String; +function DMYtoDate(Day, Month, Year : Integer) : Date; +function HMStoTime(Hours, Minutes, Seconds : Byte) : Time; +function DateToDMY(date : DateTimeRec): LongInt; +procedure SetDateTime(var DT : DateTimeRec); +function SameStruct(const Rec1, Rec2; Len : Word) : Boolean; +function LoadConfDesc(var ConfDesc : TConfDesc; Conf : Word) : Boolean; +function GetMemCheck(var P; Bytes : Word) : Boolean; +procedure FreeMemCheck(var P; Bytes : Word); +function ExistFile(const P : PathStr) : Boolean; +procedure WriteTopRight(const S : String); + +procedure SetFlag(var Flag : Word; Mask : Word); +function FlagIsSet(Flag : Word; Mask : Word) : Boolean; +procedure ClearFlag(var Flag : Word; Mask : Word); +function LongFlagIsSet(Flag : LongInt; Mask : LongInt) : Boolean; + +procedure NoteError(const S : String); +function AddBackslash(const P : PathStr) : PathStr; +function Word2Key(Num : Word) : String; +function Long2Key(Num : LongInt) : String; +function Pad(const S : String; Len : Byte) : String; +function Long2Str(L : LongInt) : String; +function Str2Long(S : String; var I : LongInt) : Boolean; +procedure LogFatalError(const ErrorSt : String; Code : Integer); +function OpenFile(var F : File; const FileName : PathStr; RecSize : Word): byte; +procedure CloseFile(var F : File); +procedure ReadFile(var F : File; RecNum : LongInt; var RecInfo; LockRec : Boolean); +procedure WriteFile(var F : File; RecNum : LongInt; var RecInfo); +procedure ReadMInfo(Lock : Boolean); +procedure WriteMInfo; +function SearchUC(const Buffer; BufLength : Word; const Match; MatLength : Word): Word; +function Trim(S : string) : string; +function ForceExtension(const S, Ext : string) : string; +function JustName(S : string) : string; +function JustExtension(S : string) : string; + +implementation + +const + HoursInDay = 24; {number of hours in a day} + SecondsInHour = 3600; {number of seconds in an hour} + SecondsInMinute = 60; {number of seconds in a minute} + SecondsInDay = 86400; {number of seconds in a day} + Threshold2000 : Integer = 1900; + MinYear = 1900; + First2Months = 58; {1900 was not a leap year} + +type + CaseTable = array[#128..#165] of Char; + +const + { CP437 uppercase mapping for chars #128..#165 } + UCTable : CaseTable = ( + #128, #154, 'E', 'A', #142, 'A', #143, #128, { 128-135: Ç ü->Ü é->E â->A ä->Ä à->A å->Å ç->Ç } + 'E', 'E', 'E', 'I', 'I', 'I', #142, #143, { 136-143: ê->E ë->E è->E ï->I î->I ì->I Ä Å } + #144, #146, #146, 'O', #153, 'O', 'U', 'U', { 144-151: É æ->Æ Æ ô->O ö->Ö ò->O û->U ù->U } + 'Y', #153, #154, #155, #156, #157, #158, #159,{ 152-159: ÿ->Y Ö Ü ¢ £ ¥ Pt ƒ } + 'A', 'I', 'O', 'U', #165, #165 { 160-165: á->A í->I ó->O ú->U ñ->Ñ Ñ } + ); + +{$IFDEF FPC} + function Upcase(C : Char) : Char; + begin + if (C >= #128) and (C <= #165) then + Upcase := UCTable[C] + else if (C >= 'a') and (C <= 'z') then + Upcase := Chr(Ord(C) - 32) + else + Upcase := C; + end; +{$ELSE} +var + UpcaseFunc : Pointer; + + + procedure UpcaseAL; assembler; + asm + cmp al,128 + jb @notex + cmp al,165 + ja @done + sub al,128 + push bx + mov bx,offset UCTable + xlat + pop bx + jmp @done + @notex: + cmp al,'a' + jb @done + cmp al,'z' + ja @done + sub al,32 + @done: + end; + + + function Upcase(C : Char) : Char; assembler; + asm + mov al,c + call UpcaseAL + end; +{$ENDIF FPC} + + + function StUpcase(S : String) : String; + var + I : Word; + + begin + for I := 1 to Length(S) do + S[I] := UpCase(S[I]); + StUpcase := S; + end; + + +{$IFDEF FPC} + procedure InitInternationalUpcase; + begin + { Under FPC, we use the built-in UCTable defaults } + { No DOS INT 21h/38h country info call needed } + end; +{$ELSE} + procedure InitInternationalUpcase; + var + C, D : Char; + CountryInfo : array[0..33] of Byte; + + begin + UpcaseFunc := nil; + asm + mov ax,3800h + lea dx,CountryInfo + push ds + push ss + pop ds + int 21h + pop ds + jc @not + les bx,dword ptr CountryInfo+18 + mov UpcaseFunc.word[0],bx + mov UpcaseFunc.word[2],es + @not: + end; + if UpcaseFunc <> nil then + for C := #128 to #165 do begin + asm + mov al,C + call UpcaseFunc + mov D,al + end; + UCTable[C] := D; + end; + end; +{$ENDIF FPC} + + + function HMStoTime(Hours, Minutes, Seconds : Byte) : Time; + var + T : Time; + + begin + Hours := Hours mod HoursInDay; + T := (LongInt(Hours) * SecondsInHour) + (LongInt(Minutes) * SecondsInMinute) + Seconds; + HMStoTime := T mod SecondsInDay; + end; + + + function CurrentTime : Time; + var + Hours, Minutes, Seconds, Sec100 : Word; + + begin + GetTime(Hours, Minutes, Seconds, Sec100); + CurrentTime := HMStoTime(Hours, Minutes, Seconds); + end; + + + function DMYtoDate(Day, Month, Year : Integer) : Date; + begin + if Word(Year) < 100 then begin + Inc(Year, 1900); + if Year < Threshold2000 then + Inc(Year, 100); + end; + if (Year = MinYear) and (Month < 3) then + if Month = 1 then + DMYtoDate := Pred(Day) + else + DMYtoDate := Day + 30 + else begin + if Month > 2 then + Dec(Month, 3) + else begin + Inc(Month, 9); + Dec(Year); + end; + Dec(Year, MinYear); + DMYtoDate := ((LongInt(Year) * 1461) div 4) + (((153 * Month) + 2) div 5) + Day + First2Months; + end; + end; + + Function DateToDMY(date : DateTimeRec): LongInt; + + const Months: Array[1..12] of byte = + (31,28,31,30,31,30,31,31,30,31,30,31); + + var dt : datetime; + t : Longint; + + begin + dt.hour := 0; + dt.min := 0; + dt.sec := 0; + + dt.month := 1; + dt.day := 0; + dt.year := MinYear; + + inc(Date.D); + + while Date.D >= 365 do + begin + dec(Date.D,365); + + if (dt.Year <> MinYear) and (dt.Year mod 4 = 0) and + (Date.D > 0) then + dec(Date.D); + + inc(dt.year); + end; + + while Date.D > Months[dt.month] + byte((dt.month = 2) and (dt.Year <> MinYear) and (dt.Year mod 4 = 0)) do + begin + dec(Date.D, Months[dt.month]); + + if (dt.month = 2) and (dt.Year <> MinYear) and (dt.Year mod 4 = 0) and + (Date.D > 0) then + dec(Date.D); + + inc(dt.month); + end; + + dt.day := Date.D; + + dt.hour := Date.T div SecondsInHour; Date.T := Date.T mod SecondsInHour; + dt.min := Date.T div SecondsInMinute; Date.T := Date.T mod SecondsInMinute; + dt.sec := Date.T; + + packtime(dt, t); + DateToDMY := t; + end; + + + function Today : Date; + var + Year, Month, Day, DayOfWeek : Word; + + begin + GetDate(Year, Month, Day, DayOfWeek); + Today := DMYtoDate(Day, Month, Year); + end; + + + procedure SetDateTime(var DT : DateTimeRec); + begin + DT.T := CurrentTime; + DT.D := Today; + end; + + + function SameStruct(const Rec1, Rec2; Len : Word) : Boolean; + type + ByteArray = array[1..65520] of Byte; + + var + I : Word; + B1 : ByteArray absolute Rec1; + B2 : ByteArray absolute Rec2; + + begin + if Len = 0 then + SameStruct := True + else begin + for I := 1 to Len do + if B1[I] <> B2[I] then begin + SameStruct := False; + Exit; + end; + SameStruct := True; + end; + end; + + + function LoadConfDesc(var ConfDesc : TConfDesc; Conf : Word) : Boolean; + var + F : File; + ConfRecSize, FileRecSize, SaveFileMode : Word; + + begin + FileRecSize := (MwConfig^.MaxFileAreas - 1) div 8 + 1; + ConfRecSize := SizeOf(TConfDesc) + FileRecSize; + Assign(F, 'CONFDESC.DAT'); + SaveFileMode := FileMode; + FileMode := ShareMode; + Reset(F, 1); + FileMode := SaveFileMode; + if IoResult = 0 then begin + Seek(F, LongInt(ConfRecSize) * Conf); + BlockRead(F, ConfDesc, SizeOf(ConfDesc)); + if IoResult = 0 then + {ignore}; + Close(F); + if IoResult = 0 then + {ignore}; + LoadConfDesc := True; + end else + LoadConfDesc := False; + end; + + +{$IFDEF FPC} + function GetMemCheck(var P; Bytes : Word) : Boolean; + var + Pt : Pointer absolute P; + begin + Pt := nil; + GetMem(Pt, Bytes); + GetMemCheck := Pt <> nil; + end; +{$ELSE} + function HeapFunc(Size : Word) : Integer; far; + begin + if Size = 0 then + HeapFunc := 2 + else + HeapFunc := 1; + end; + + + function GetMemCheck(var P; Bytes : Word) : Boolean; + var + Pt : Pointer absolute P; + SaveHeapError : Pointer; + + begin + SaveHeapError := HeapError; + HeapError := @HeapFunc; + GetMem(Pt, Bytes); + GetMemCheck := Pt <> nil; + HeapError := SaveHeapError; + end; +{$ENDIF FPC} + + + procedure FreeMemCheck(var P; Bytes : Word); + var + Pt : Pointer absolute P; + + begin + if Pt <> nil then begin + FreeMem(Pt, Bytes); + Pt := nil; + end; + end; + + + function ExistFile(const P : PathStr) : Boolean; + var + F : File; + SaveFileMode : Word; + + begin + Assign(F, P); + SaveFileMode := FileMode; + FileMode := ShareMode; + Reset(F); + FileMode := SaveFileMode; + if IoResult = 0 then begin + Close(F); + if IoResult = 0 then + {ignore}; + ExistFile := True; + end else + ExistFile := False; + end; + + + procedure WriteTopRight(const S : String); + var + X, Y : Byte; + + begin + X := WhereX; + Y := WhereY; + GotoXY(65, 1); + Write(S); + GotoXY(X, Y); + end; + + + procedure SetFlag(var Flag : Word; Mask : Word); + begin + Flag := Flag or Mask; + end; + + + function FlagIsSet(Flag : Word; Mask : Word) : Boolean; + begin + FlagIsSet := Flag and Mask = Mask; + end; + + + procedure ClearFlag(var Flag : Word; Mask : Word); + begin + Flag := Flag and not Mask; + end; + + + function LongFlagIsSet(Flag : LongInt; Mask : LongInt) : Boolean; + begin + LongFlagIsSet := Flag and Mask = Mask; + end; + + + + + + + procedure NoteError(const S : String); + begin + end; + + + + + function AddBackslash(const P : PathStr) : PathStr; + {$IFDEF UNIX} + const + Sep = '/'; + {$ELSE} + const + Sep = '\'; + {$ENDIF} + begin + if (Length(P) = 0) or ((P[Length(P)] <> '\') and (P[Length(P)] <> '/')) then + AddBackslash := P + Sep + else + AddBackslash := P; + end; + + + function Word2Key(Num : Word) : String; + begin + Word2Key := CStyleNumKey(WordToKey(Num)); + end; + + + function Long2Key(Num : LongInt) : String; + begin + Long2Key := CStyleNumKey(LongToKey(Num)); + end; + + + function Pad(const S : String; Len : Byte) : String; + var + Result : String; + + begin + if Length(S) >= Len then + Pad := S + else begin + Result[0] := Chr(Len); + Move(S[1], Result[1], Length(S)); + if Len < 255 then + FillChar(Result[Length(S) + 1], Len - Length(S), ' '); + Pad := Result; + end; + end; + + + function Long2Str(L : LongInt) : String; + var + S : String; + + begin + Str(L, S); + Long2Str := S; + end; + + + function Str2Long(S : String; var I : LongInt) : Boolean; + var + Code : Word; + SLen : Byte absolute S; + + begin + while S[SLen] = ' ' do + Dec(SLen); + if (SLen > 1) and (Upcase(S[SLen]) = 'H') then begin + Move(S[1], S[2], SLen - 1); + S[1] := '$'; + end else if (SLen > 2) and (S[1] = '0') and (Upcase(S[2]) = 'X') then begin + Dec(SLen); + Move(S[3], S[2], SLen-1); + S[1] := '$'; + end; + Val(S, I, Code); + if Code <> 0 then begin + I := Code; + Str2Long := False; + end else + Str2Long := True; + end; + + + procedure LogFatalError(const ErrorSt : String; Code : Integer); + begin + { Procedure commented out to prevent WC_DEV from halting } + { ALLFIX } + + { + Window(1, 1, 80, 25); + ClrScr; + } + WriteLn('Fatal Error - '+ErrorSt+' Code - '+Long2Str(Code)); + { + Halt; + } + end; + + + function GetFileRecName(var F : File) : PathStr; + var + S : PathStr; + SLen : Byte absolute S; + + begin + SLen := 0; + while (SLen < 79) and (FileRec(F).Name[SLen] <> #0) do + Inc(SLen); + Move(FileRec(F).Name[0], S[1], SLen); + GetFileRecName := S; + end; + + + function IsLockOkayPrim(CheckLockError : Boolean; const Name : String) : Boolean; + const + MaxRetries = 50; + + const + Retries : Byte = 0; + + begin + if not CheckLockError then + begin + IsLockOkayPrim := True; + Retries := 0; + end + else if Retries < MaxRetries then + begin + IsLockOkayPrim := False; + Inc(Retries); + Delay(500+Random(500)); + end + else + LogFatalError('Unable to lock file '+Name, IsamError); + end; + + + function IsFilerOkay(const Name : String) : Boolean; + begin + IsFilerOkay := IsLockOkayPrim(not IsamOk and (BtIsamErrorClass = 2), Name); + end; + + + function IsDosOkay(FileResult : Word; const Name : String) : Boolean; + begin + IsDosOkay := IsLockOkayPrim(FileResult = 5, Name); + end; + + + procedure LockDosRecord(Handle : Word; Start, Len : LongInt; const Name : String); + begin + repeat + IsamClearOk; + if not BtIsamLockRecord(Start, Len, Handle, 1, 1) then + begin + IsamOk := False; + IsamError := 10335; + end; + until IsFilerOkay(Name); + end; + + + procedure UnLockDosRecord(Handle : Word; Start, Len : LongInt; const Name : String); + begin + repeat + IsamClearOk; + if not BtIsamUnLockRecord(Start, Len, Handle) then + begin + IsamOk := False; + IsamError := 10340; + end; + until IsFilerOkay(Name); + end; + + + Function OpenFile(var F : File; const FileName : PathStr; RecSize : Word): byte; + var + ErrCode : Word; + + begin + FileMode := ShareMode; + Assign(F, FileName); + repeat + Reset(F, RecSize); + ErrCode := IoResult; + until IsDosOkay(ErrCode, FileName); + OpenFile := ErrCode; + end; + + + procedure CloseFile(var F : File); + var + ErrCode : Word; + + begin + repeat + Close(F); + ErrCode := IoResult; + until IsDosOkay(ErrCode, GetFileRecName(F)); + if ErrCode <> 0 then + LogFatalError('Error closing file '+GetFileRecName(F), ErrCode); + end; + + + procedure ReadFile(var F : File; RecNum : LongInt; var RecInfo; LockRec : Boolean); + var + ErrCode : Word; + LockPos : LongInt; + + begin + if LockRec then + begin + LockPos := RecNum * FileRec(F).RecSize; + LockDosRecord(FileRec(F).Handle, LockPos, FileRec(F).RecSize, GetFileRecName(F)); + end; + repeat + Seek(F, RecNum); + ErrCode := IoResult; + until IsDosOkay(ErrCode, GetFileRecName(F)); + if ErrCode <> 0 then + LogFatalError('Error seeking file '+GetFileRecName(F), ErrCode); + repeat + BlockRead(F, RecInfo, 1); + ErrCode := IoResult; + until IsDosOkay(ErrCode, GetFileRecName(F)); + if ErrCode <> 0 then + LogFatalError('Error reading file '+GetFileRecName(F), ErrCode); + end; + + + procedure WriteFile(var F : File; RecNum : LongInt; var RecInfo); + var + ErrCode : Word; + LockPos : LongInt; + + begin + repeat + Seek(F, RecNum); + ErrCode := IoResult; + until IsDosOkay(ErrCode, GetFileRecName(F)); + if ErrCode <> 0 then + LogFatalError('Error seeking file '+GetFileRecName(F), ErrCode); + repeat + BlockWrite(F, RecInfo, 1); + ErrCode := IoResult; + until IsDosOkay(ErrCode, GetFileRecName(F)); + if ErrCode <> 0 then + LogFatalError('Error writing file '+GetFileRecName(F), ErrCode); + LockPos := RecNum * FileRec(F).RecSize; + UnLockDosRecord(FileRec(F).Handle, LockPos, FileRec(F).RecSize, GetFileRecName(F)); + end; + + + procedure ReadMInfo(Lock : Boolean); + begin + ReadFile(NodeInfoFile, 0, MasterInfo^, Lock); + end; + + + procedure WriteMInfo; + begin + WriteFile(NodeInfoFile, 0, MasterInfo^); + end; + + + function Trim(S : string) : string; + var + I : Word; + SLen : Byte absolute S; + + begin + while (SLen > 0) and (S[SLen] <= ' ') do + Dec(SLen); + + I := 1; + while (I <= SLen) and (S[I] <= ' ') do + Inc(I); + Dec(I); + if I > 0 then + Delete(S, 1, I); + + Trim := S; + end; + + + +{$IFDEF FPC} + function SearchUC(const Buffer; BufLength : Word; const Match; MatLength : Word): Word; + var + BufP : PByte; + MatP : PByte; + I, J : Word; + Found : Boolean; + begin + SearchUC := $FFFF; + if MatLength = 0 then Exit; + if BufLength < MatLength then Exit; + BufP := @Buffer; + MatP := @Match; + for I := 0 to BufLength - MatLength do begin + Found := True; + for J := 0 to MatLength - 1 do begin + if Upcase(Chr(BufP[I + J])) <> Upcase(Chr(MatP[J])) then begin + Found := False; + Break; + end; + end; + if Found then begin + SearchUC := I; + Exit; + end; + end; + end; +{$ELSE} + function SearchUC(const Buffer; BufLength : Word; const Match; MatLength : Word): Word; assembler; + asm + push ds + cld + les di,Buffer + mov bx,di + mov cx,BufLength + mov dx,MatLength + or dx,dx + jz @error + lds si,Match + lodsb + call UpcaseAL + dec dx + sub cx,dx + jbe @error + @next: + jcxz @error + mov ah,es:[di] + inc di + xchg al,ah + call UpcaseAL + xchg al,ah + cmp ah,al + loopne @next + jne @error + or dx,dx + jz @found + push ax + push cx + push di + push si + mov cx,dx + @next1: + lodsb + call UpcaseAL + mov ah,es:[di] + inc di + xchg al,ah + call UpcaseAL + xchg al,ah + cmp ah,al + loope @next1 + pop si + pop di + pop cx + pop ax + jne @next + @found: + dec di + mov ax,di + sub ax,bx + jmp @out + @error: + xor ax,ax + dec ax + @out: + pop ds + end; +{$ENDIF FPC} + +function ForceExtension(const S, Ext : string) : string; +var + Temp : string; + +begin + if pos('.',s) > 0 then + Temp := Copy(S, 1, Pos('.', S)-1) else + Temp := S; + + ForceExtension := Temp+'.'+Ext; +end; + + +function JustName(S : string) : string; +var + X, + Y, + Len : Byte; + +begin + for Len := Length(S) downto 1 do + begin + X := Len; + if S[Len] = '\' then + break; + end; + + Y := Pos('.', S); + if Y = 0 then + Y := Length(S); + + JustName := Copy(S, X+1, Y); +end; + + +function JustExtension(S : string) : string; +begin + JustExtension := ''; + if Pos('.', S) <> 0 then + JustExtension := Copy(S, Pos('.', S), Length(S)); +end; + + +begin + InitInternationalUpcase; +end. diff --git a/src/wc_sdk/wcmsgdb.pas b/src/wc_sdk/wcmsgdb.pas new file mode 100755 index 0000000..b1ec8ab --- /dev/null +++ b/src/wc_sdk/wcmsgdb.pas @@ -0,0 +1,997 @@ +{$IFDEF FPC}{$I-}{$V-}{$ENDIF} +{$O+} + +unit WcMsgDb; + +interface + + +uses + Dos, + Crt, + Desq, + WcType, + Filer, + BTISBase, + WcMisc, + WcDb, + WcUserDb, + WcGlobal; + +const + MagicHeaderActive = $001A1A1B; + MagicHeaderInactive = $011A1A1B; + +type + { This is an artifact of how Wildcat used to work and is not stored in } + { a database anywhere. It is used by TMsgDatabase::GetMsgStatus which } + { creates one of these from information in the database. } + TMsgStatus = record + LowMsg, + HighMsg, + ActiveMsg : Word; + end; + +type + PMsgDatabase = ^TMsgDatabase; + TMsgDatabase = object + constructor Init; + function IsOpen(CheckConf : Word) : Boolean; + function Open(AConf : Word; TSecondary : Boolean) : Boolean; + procedure Done; + procedure Lock; + procedure Unlock; + function DatabaseActive : Boolean; + function AddMsg(var ref: Longint; var msg: TMsgHeader; var msgtext: file) : Boolean; + function FindMsg(msgnum: Word): Longint; + function SearchMsg(msgnum: Word): Longint; + procedure NextMsg(var ref: Longint); + procedure PrevMsg(var ref: Longint); + procedure GetMsgStatus(var msr: TMsgStatus); + procedure GetMsgHeader(ref: Longint; var msg: TMsgHeader); + procedure GetMsgHeaderAndText(ref: Longint; var msg: TMsgHeader; buffer: PMsgText; offset, len: Word); + procedure UpdateMsgHeader(var NewMsg: TMsgHeader); + procedure UpdateMsgHeaderAndText(var NewMsg: TMsgHeader; msgtext: PMsgText); + procedure UpdateMsgText(ref: Longint; msgtext: PMsgText; offset, len: Word); + procedure SetMsgFlagsNum(MsgNumber: Word; NewMsgFlags : Word); + procedure MarkMsgRead(var MsgHdr : TMsgHeader); + procedure UpdateMasterInfo; + private + AlreadyOpen : Boolean; + Secondary : Boolean; + Conf: Word; + IndexFile: File; + DataFile: File; + LockCount: Integer; + MsgCountDelta : LongInt; + function IndexOffset(index: Word): Longint; + function OffsetIndex(ofs: Longint): Word; + procedure FatalDBError(const S : String); + procedure LogDBError(const S : String); + function FindMsgIndex(msgnum: Word; var msghdr: TMsgHeader): Word; + procedure ReadIndexHeader(var header: TMsgIndexHeader); + procedure WriteIndexHeader(var header: TMsgIndexHeader); + function ReadMsgHeader(index: Word; var msghdr: TMsgHeader): Boolean; + procedure WriteMsgHeader(index: Word; var msghdr: TMsgHeader); + procedure UnhookMessage(index: Word; var msghdr: TMsgHeader); + procedure UpdateNodeInfo(CurConf : LongInt); + (* + procedure IntegrityCheck(const where: String; userid: Longint); + *) + end; + +var + MsgDb : PMsgDatabase; + +{const + MsgDbOpen : Integer = 0;} + +implementation + + constructor TMsgDatabase.Init; + begin + AlreadyOpen := False; + end; + + + function TMsgDatabase.IsOpen(CheckConf : Word) : Boolean; + begin + IsOpen := (CheckConf = Conf) and AlreadyOpen; + end; + + + function TMsgDatabase.Open(AConf: Word; TSecondary : Boolean) : Boolean; + var + fn: String; + header: TMsgIndexHeader; + ie: TMsgIndexEntry; + index: Word; + cd: TConfDesc; + + begin + LockCount := 0; + IsamClearOk; + Conf := AConf; + Open := False; + if AlreadyOpen then + Done; + Secondary := TSecondary; + if ExistFile('MSGLOCK\'+Long2Str(Conf)+'.LCK') then + Exit + else + UpdateNodeInfo(Conf); + LoadConfDesc(cd, Conf); + + {$IFDEF TEST} + cd.MsgPath := 'E:\TMP9\'; + {$ENDIF} + + fn := AddBackSlash(cd.MsgPath) + 'MSG' + Long2Str(Conf); + Assign(IndexFile, fn+'.IX'); + FileMode := $42; + Reset(IndexFile, 1); + if IoResult <> 0 then begin + Rewrite(IndexFile, 1); + if IoResult <> 0 then begin + IsamOk := False; + IsamError := 9903; + UpdateNodeInfo(-1); + Exit; + end; + FillChar(header, sizeof(header), 0); + header.RecordSize := sizeof(TMsgIndexEntry); + header.ActiveRecords := 0; + header.NextMsgNumber := 1; + BlockWrite(IndexFile, header, sizeof(header)); + if IoResult <> 0 then begin + IsamOk := False; + {IsamError := 9903;} + LogError('Error creating conference '+Long2Str(Conf), 9903); + UpdateNodeInfo(-1); + Exit; + end; + end; + ReadIndexHeader(header); + if (header.RecordSize <> sizeof(TMsgIndexEntry)) then begin + Close(IndexFile); + IsamOk := False; + LogError('Corrupted header on conference '+Long2Str(Conf), 10120); + {IsamError := 10120;} + UpdateNodeInfo(-1); + Exit; + end; + index := OffsetIndex(FileSize(IndexFile)); + if index > 1 then begin + Seek(IndexFile, IndexOffset(index-1)); + BlockRead(IndexFile, ie, sizeof(TMsgIndexEntry)); + if (IoResult <> 0) and (header.NextMsgNumber <= ie.MsgNumber) then begin + header.NextMsgNumber := ie.MsgNumber + 1; + WriteIndexHeader(header); + end; + end; + Assign(DataFile, fn+'.DAT'); + FileMode := $42; + Reset(DataFile, 1); + if IoResult <> 0 then begin + Rewrite(DataFile, 1); + if IoResult <> 0 then begin + Close(IndexFile); + IsamOk := False; + {IsamError := 9903;} + LogError('Error creating DAT for conference '+Long2Str(Conf), 9903); + UpdateNodeInfo(-1); + Exit; + end; + end; + Open := True; + AlreadyOpen := True; + MsgCountDelta := 0; +{ FastWrite(Long2Str(MsgDbOpen), ScreenHeight, 1, $4F);} + end; + + + procedure TMsgDatabase.Done; + begin + if not AlreadyOpen then + Exit; + AlreadyOpen := False; + while LockCount > 0 do + Unlock; + if MsgCountDelta <> 0 then + UpdateMasterInfo; + Close(IndexFile); + Close(DataFile); + UpdateNodeInfo(-1); + end; + + + function TMsgDataBase.DatabaseActive : Boolean; + begin + DataBaseActive := AlreadyOpen; + end; + + + procedure TMsgDatabase.Lock; + var + retries : Word; + + begin + if LockCount = 0 then begin + retries := 0; + while not BTIsamLockRecord(0, 1, FileRec(IndexFile).Handle, 768, 64) do begin + IsamDelay(Random(200)); + Inc(retries); + if retries > 50 then + LogFatalError('Error locking message database', IsamError); + WriteTopRight('Lock retry #'+Long2Str(retries)); + end; + if retries > 0 then + WriteTopRight(' '); + end; + Inc(LockCount); + end; + + + procedure TMsgDatabase.Unlock; + + begin + Dec(LockCount); + if LockCount = 0 then begin + { + Commit(IndexFile); + Commit(DataFile); + } + if not BTIsamUnLockRecord(0, 1, FileRec(IndexFile).Handle) then + LogFatalError('Error unlocking message database', IsamError); + end; + end; + + function TMsgDatabase.AddMsg(var ref : LongInt; var msg: TMsgHeader; var msgtext: file) : Boolean; + var + header: TMsgIndexHeader; + ie: TMsgIndexEntry; + userref: Longint; + userrec: TUserRec; + tuserconf: PUserWrapper; + firstunread: Word; + tmsghdr, tmsghdr2: TMsgHeader; + tindex, tindex2: Word; + b: Byte; + SendNotification : Boolean; + nw,nr : word; + buf : array[1..2048] of byte; + + begin + AddMsg := False; + SendNotification := False; + IsamClearOk; + Lock; + ReadIndexHeader(header); + if header.NextMsgNumber < 65520 then begin + (* + IntegrityCheck('AddMsg start', msg.DestUserId); + *) + + msg.MagicNumber := MagicHeaderActive; + msg.MsgNumber := header.NextMsgNumber; + msg.NextUnread := 0; + msg.PrevUnread := 0; + + if (msg.DestUserID > 0) and not FlagIsSet(msg.mFlags, mfReceived) then + begin + UserDB^.Lock; + if UserDB^.FindKey(UserIDKey, userref, BuildUserIdKey(msg.DestUserId)) then begin + SendNotification := True; + SetFlag(msg.mFlags, mfReceiveable); + UserDB^.GetRec(userref, userrec); + tuserconf := New(PUserWrapper, Init(userrec)); + firstunread := tuserconf^.GetFirstUnread(Conf); + if firstunread = 0 then begin + msg.PrevUnread := msg.MsgNumber; + msg.NextUnread := msg.MsgNumber; + tuserconf^.SetFirstUnread(Conf, msg.MsgNumber); + end else begin + tindex := FindMsgIndex(firstunread, tmsghdr); + if IsamOk and (tmsghdr.destuserid = userrec.userid) then begin + if tmsghdr.PrevUnread = firstunread then begin + tmsghdr.NextUnread := msg.MsgNumber; + tmsghdr.PrevUnread := msg.MsgNumber; + WriteMsgHeader(tindex, tmsghdr); + msg.NextUnread := tmsghdr.MsgNumber; + msg.PrevUnread := tmsghdr.MsgNumber; + end else begin + msg.NextUnread := tmsghdr.MsgNumber; + tindex2 := FindMsgIndex(tmsghdr.PrevUnread, tmsghdr2); + if IsamOk then begin + msg.PrevUnread := tmsghdr2.MsgNumber; + tmsghdr.PrevUnread := msg.MsgNumber; + WriteMsgHeader(tindex, tmsghdr); + tmsghdr2.NextUnread := msg.MsgNumber; + WriteMsgHeader(tindex2, tmsghdr2); + end; + end; + end else begin + msg.PrevUnread := msg.MsgNumber; + msg.NextUnread := msg.MsgNumber; + tuserconf^.SetFirstUnread(Conf, msg.MsgNumber); + end; + end; + Dispose(tuserconf, Done); + end; + UserDB^.Unlock; + end; + + ie.MsgNumber := msg.MsgNumber; + ie.HeaderOffset := FileSize(DataFile); + Seek(IndexFile, FileSize(IndexFile)); + BlockWrite(IndexFile, ie, sizeof(TMsgIndexEntry)); + + Seek(DataFile, ie.HeaderOffset); + BlockWrite(DataFile, msg, sizeof(TMsgHeader)); + if msg.MsgBytes > 0 then + begin + seek(msgtext, 0); + repeat + blockread(msgtext, buf, sizeof(buf), nr); + blockwrite(DataFile, buf, nr, nw); + until nr = 0; + end else + begin + Seek(DataFile, FilePos(DataFile) + msg.MsgBytes-1); + b := 0; + BlockWrite(DataFile, b, 1); + end; + + ref := OffsetIndex(FilePos(IndexFile)) - 1; + Inc(header.NextMsgNumber); + Inc(header.ActiveRecords); + WriteIndexHeader(header); + + (* + IntegrityCheck('AddMsg end', msg.DestUserId); + *) + + Inc(MsgCountDelta); + AddMsg := True; + end + else begin + IsamError := 10666; + end; + + Unlock; + end; + + function TMsgDatabase.FindMsgIndex(msgnum: Word; var msghdr: TMsgHeader): Word; + var + left, right, mid, last: Longint; + ie: TMsgIndexEntry; + ref: Longint; + begin + IsamClearOk; + left := 1; + last := Longint(OffsetIndex(FileSize(IndexFile))); + right := last - 1; + ref := last; + while left <= right do begin + mid := (left + right) div 2; + Seek(IndexFile, IndexOffset(mid)); + BlockRead(IndexFile, ie, sizeof(TMsgIndexEntry)); + if IoResult <> 0 then + Break; + if msgnum = ie.MsgNumber then begin + ReadMsgHeader(mid, msghdr); + FindMsgIndex := mid; + Exit; + end + else if msgnum < ie.MsgNumber then begin + ref := mid; + right := mid - 1; + end + else + left := mid + 1; + end; + IsamOk := False; + if ref < last then + IsamError := 10200 + else + IsamError := 10210; + FindMsgIndex := ref; + end; + + function TMsgDatabase.FindMsg(msgnum: Word): Longint; + var + msghdr: TMsgHeader; + begin + FindMsg := FindMsgIndex(msgnum, msghdr); + end; + + function TMsgDatabase.SearchMsg(msgnum: Word): Longint; + + begin + IsamClearOk; + SearchMsg := FindMsg(msgnum); + if not IsamOk and (IsamError = 10200) then + IsamOk := True; + end; + + procedure TMsgDatabase.NextMsg(var ref: Longint); + + begin + IsamClearOk; + Inc(ref); + IsamOk := IndexOffset(ref) < FileSize(IndexFile); + if not IsamOk then + IsamError := 10250; + end; + + procedure TMsgDatabase.PrevMsg(var ref: Longint); + + begin + IsamClearOk; + Dec(ref); + IsamOk := ref > 0; + if not IsamOk then + IsamError := 10260; + end; + + + procedure TMsgDatabase.GetMsgStatus(var msr: TMsgStatus); + var + header: TMsgIndexHeader; + msghdr: TMsgHeader; + begin + IsamClearOk; + ReadIndexHeader(header); + FillChar(msr, sizeof(msr), 0); + if ReadMsgHeader(1, msghdr) then + msr.LowMsg := msghdr.MsgNumber; + msr.HighMsg := header.NextMsgNumber - 1; + msr.ActiveMsg := header.ActiveRecords; + end; + + + procedure TMsgDatabase.GetMsgHeader(ref: Longint; var msg: TMsgHeader); + + begin + IsamClearOk; + IsamOk := (ref > 0) and ReadMsgHeader(ref, msg); + if not IsamOk then + IsamError := 10070; + end; + + procedure TMsgDatabase.GetMsgHeaderAndText(ref: Longint; var msg: TMsgHeader; buffer: PMsgText; offset, len: Word); + var + ofs: Longint; + x: Word; + + begin + IsamClearOk; + if ref <= 0 then + begin + IsamOk := False; + IsamError := 10131; + Exit; + end; + if not ReadMsgHeader(ref, msg) then + begin + IsamOk := False; + IsamError := 10070; + Exit; + end; + if offset > 0 then + Seek(DataFile, FilePos(DataFile)+offset); + if offset < msg.MsgBytes then + begin + x := msg.MsgBytes - offset; + if len > x then + len := x; + BlockRead(DataFile, buffer^, len); + if IoResult <> 0 then + begin + IsamOk := False; + IsamError := 10070; + end; + end; + end; + + + procedure TMsgDatabase.UpdateMsgHeader(var NewMsg: TMsgHeader); + var + iheader: TMsgIndexHeader; + header: TMsgHeader; + index: Word; + begin + Lock; + ReadIndexHeader(iheader); + index := FindMsgIndex(NewMsg.MsgNumber, header); + if IsamOk then begin + ClearFlag(NewMsg.mFlags, mfReceived); + SetFlag(NewMsg.mFlags, header.mFlags and mfReceived); + NewMsg.NextUnread := header.NextUnread; + NewMsg.PrevUnread := header.PrevUnread; + WriteMsgHeader(index, NewMsg); + if header.mFlags and mfDeleted <> NewMsg.mFlags and mfDeleted then + begin + if NewMsg.mFlags and mfDeleted <> 0 then + Dec(iheader.ActiveRecords) + else + Inc(iheader.ActiveRecords); + WriteIndexHeader(iheader); + end; + end; + Unlock; + end; + + procedure TMsgDatabase.UpdateMsgHeaderAndText(var NewMsg: TMsgHeader; msgtext: PMsgText); + var + iheader: TMsgIndexHeader; + header: TMsgHeader; + index: Word; + ofs: Longint; + ie: TMsgIndexEntry; + io: Integer; + b : byte; + + begin + Lock; + ReadIndexHeader(iheader); + index := FindMsgIndex(NewMsg.MsgNumber, header); + if IsamOk and (NewMsg.MsgNumber = header.MsgNumber) then begin + ClearFlag(NewMsg.mFlags, mfReceived); + SetFlag(NewMsg.mFlags, header.mFlags and mfReceived); + NewMsg.NextUnread := header.NextUnread; + NewMsg.PrevUnread := header.PrevUnread; + ReadMsgHeader(index, header); + if NewMsg.MsgBytes <= header.MsgBytes then begin + if msgtext <> nil then + BlockWrite(DataFile, msgtext^, NewMsg.MsgBytes); + WriteMsgHeader(index, NewMsg); + end + else begin + header.MagicNumber := MagicHeaderInactive; + WriteMsgHeader(index, header); + ofs := FileSize(DataFile); + Seek(DataFile, ofs); + BlockWrite(DataFile, NewMsg, sizeof(TMsgHeader)); + if msgtext <> nil then + BlockWrite(DataFile, msgtext^, NewMsg.MsgBytes) + else if NewMsg.MsgBytes > 0 then begin + Seek(DataFile, FilePos(DataFile) + NewMsg.MsgBytes-1); + b := 0; + BlockWrite(DataFile, b, 1); + end; + ie.MsgNumber := NewMsg.MsgNumber; + ie.HeaderOffset := ofs; + Seek(IndexFile, IndexOffset(index)); + BlockWrite(IndexFile, ie, sizeof(TMsgIndexEntry)); + io := IoResult; + if io <> 0 then begin + IsamError := 9500+io; + FatalDbError('Error writing index entry'); + end; + end; + if header.mFlags and mfDeleted <> NewMsg.mFlags and mfDeleted then + begin + if NewMsg.mFlags and mfDeleted <> 0 then + Dec(iheader.ActiveRecords) + else + Inc(iheader.ActiveRecords); + WriteIndexHeader(iheader); + end; + end; + Unlock; + end; + + procedure TMsgDatabase.UpdateMsgText(ref: Longint; msgtext: PMsgText; offset, len: Word); + + var hdr: TMsgHeader; + + begin + Lock; + if not ReadMsgHeader(ref, hdr) then + Exit; + if offset >= hdr.MsgBytes then + Exit; + if offset+len > hdr.MsgBytes then + len := hdr.MsgBytes - offset; + { this now relies on the fact that ReadMsgHeader leaves the file pointer + for the .dat file at the start of the message text } + Seek(DataFile, FilePos(DataFile) + offset); + BlockWrite(DataFile, msgtext^, len); + Unlock; + end; + + procedure TMsgDatabase.SetMsgFlagsNum(MsgNumber: Word; NewMsgFlags : Word); + var + header: TMsgHeader; + index: Word; + begin + index := FindMsgIndex(MsgNumber, header); + if IsamOk then begin + if FlagIsSet(NewMsgFlags, mfDeleted) and not FlagIsSet(header.mFlags, mfDeleted) then + Dec(MsgCountDelta); + SetFlag(header.mFlags, NewMsgFlags); + WriteMsgHeader(index, header); + end; + end; + + + procedure TMsgDatabase.MarkMsgRead(var MsgHdr : TMsgHeader); + var + index: Word; + begin + MsgDB^.Lock; + index := FindMsgIndex(msghdr.MsgNumber, msghdr); + if IsamOk then begin + SetDateTime(msghdr.ReadTime); + SetFlag(msghdr.mFlags, mfReceived); + UnhookMessage(index, msghdr); + end; + MsgDB^.Unlock; + end; + + procedure TMsgDatabase.UpdateNodeInfo(CurConf : LongInt); + var + f : file of TNodeInfo; + NI : TNodeInfo; + Io : Word; + Retries: Word; + + procedure UnLockNode; + begin + if not BTIsamUnLockRecord(0, SizeOf(TNodeInfo), FileRec(f).Handle) then + FatalDBError('Error unlocking NODEINFO.DAT'); + end; + + + begin + Assign(f, MwConfig^.NodeInfoPath + 'NODEINFO.DAT'); + Filemode := $42; + Reset(f); + Io := IoResult; + if Io <> 0 then + FatalDBError('Unable to open NODEINFO.DAT.'); + + if Io = 4 then exit; { abort, becuase there are not enough filehandles } + + Retries := 0; + while not BTIsamLockRecord(0, SizeOf(TMasterInfo), FileRec(f).Handle, IsamLockTimeOut, IsamDelayBetwLocks) do + begin + Inc(Retries); + if Retries = 50 then + FatalDBError('Unable to lock NODEINFO.DAT.'); + WcDelay(5 + Random(10)); + end; + + Seek(f, MwConfig^.NodeId+1); + Read(f, NI); + + Io := IoResult; + if Io <> 0 then + begin + UnLockNode; + FatalDBError('Unable to read from NODEINFO.DAT.'); + end; + + if Secondary then + NI.LockConf2 := CurConf + else + NI.LockConf1 := CurConf; + + Seek(f, MwConfig^.NodeId+1); + Write(f, NI); + UnLockNode; + Io := IoResult; + if Io <> 0 then + FatalDBError('Unable to write to NODEINFO.DAT.'); + Close(f); + if IoResult <> 0 then ; + end; + + + procedure TMsgDatabase.UpdateMasterInfo; + + var + f : file of TMasterInfo; + {FT : Text;} + MI : TMasterInfo; + Io : Word; + Retries: Word; + + procedure UnLockNode; + begin + if not BTIsamUnLockRecord(0, SizeOf(TNodeInfo), FileRec(f).Handle) then + FatalDBError('Error unlocking NODEINFO.DAT'); + end; + + + begin + Assign(f, MwConfig^.NodeInfoPath + 'NODEINFO.DAT'); + Filemode := $42; + Reset(f); + Io := IoResult; + if Io <> 0 then + FatalDBError('Unable to open NODEINFO.DAT.'); + + if Io = 4 then exit; { abort, becuase there are not enough filehandles } + + Retries := 0; + while not BTIsamLockRecord(0, SizeOf(TMasterInfo), FileRec(f).Handle, IsamLockTimeOut, IsamDelayBetwLocks) do + begin + Inc(Retries); + if Retries = 50 then + FatalDBError('Unable to lock NODEINFO.DAT.'); + WcDelay(5 + Random(10)); + end; + + Read(f, MI); + Io := IoResult; + if Io <> 0 then + begin + UnLockNode; + FatalDBError('Unable to read from NODEINFO.DAT.'); + end; + Inc(MI.TotalMessages, MsgCountDelta); + if (MsgCountDelta > 0) then {Do not Subtract From Dailys} + Inc(MI.TempMsgs, MsgCountDelta); + Seek(f, 0); + Write(f, MI); + UnLockNode; + + Io := IoResult; + if Io <> 0 then + FatalDBError('Unable to write to NODEINFO.DAT.'); + Close(f); + if IoResult <> 0 then ; + + (* + + Assign(FT, MwConfig^.NodeInfoPath+'DELTA.LOG'); + + if ExistFile(MwConfig^.NodeInfoPath+'DELTA.LOG') then + Append(FT) + else + ReWrite(FT); + + if IoResult = 0 then + begin + WriteLn(FT, '--------------------------------'); + if IoResult <> 0 then ; + WriteLn(FT, 'Node : '+Long2Str(MwConfig^.NodeId)); + if IoResult <> 0 then ; + WriteLn(FT, 'User : '+User.UserName); + if IoResult <> 0 then ; + WriteLn(FT, 'Time : '+ShortDate+' '+TimeStr); + if IoResult <> 0 then ; + WriteLn(FT, 'Delta : '+Long2Str(MsgCountDelta)); + if IoResult <> 0 then ; + Close(FT); + if IoResult <> 0 then ; + end; + + *) + + MsgCountDelta := 0; + end; + + + procedure TMsgDatabase.FatalDBError(const S : String); + begin + LogFatalError('MESSAGE DATABASE (Conference '+Long2Str(Conf)+') : '+ S, IsamError); + end; + + procedure TMsgDatabase.LogDBError(const S : String); + begin + LogError('MESSAGE DATABASE (Conference '+Long2Str(Conf)+') : ' + S, IsamError); + end; + + function TMsgDatabase.IndexOffset(index: Word): Longint; + + begin + IndexOffset := Longint(index)*sizeof(TMsgIndexEntry); + end; + + function TMsgDatabase.OffsetIndex(ofs: Longint): Word; + + begin + OffsetIndex := ofs div sizeof(TMsgIndexEntry); + end; + + procedure TMsgDatabase.ReadIndexHeader(var header: TMsgIndexHeader); + var + nr, io: Word; + begin + Lock; + Seek(IndexFile, 0); + BlockRead(IndexFile, header, sizeof(TMsgIndexHeader), nr); + io := IoResult; + if (io <> 0) or (nr <> sizeof(TMsgIndexHeader)) then begin + if io <> 0 then + IsamError := 9500+io + else + IsamError := 10070; + FatalDbError('Error reading index header'); + end; + Unlock; + end; + + procedure TMsgDatabase.WriteIndexHeader(var header: TMsgIndexHeader); + var + io: Word; + begin + Seek(IndexFile, 0); + BlockWrite(IndexFile, header, sizeof(TMsgIndexHeader)); + io := IoResult; + if io <> 0 then begin + IsamError := 9500+io; + FatalDbError('Error writing index header'); + end; + end; + + function TMsgDatabase.ReadMsgHeader(index: Word; var msghdr: TMsgHeader): Boolean; + var + ie: TMsgIndexEntry; + nr: Word; + begin + ReadMsgHeader := False; + Seek(IndexFile, IndexOffset(index)); + BlockRead(IndexFile, ie, sizeof(TMsgIndexEntry), nr); + if (IoResult <> 0) or (nr <> sizeof(TMsgIndexEntry)) then begin + IsamOk := False; + IsamError := 10070; + Exit; + end; + Seek(DataFile, ie.HeaderOffset); + BlockRead(DataFile, msghdr, sizeof(TMsgHeader), nr); + if IoResult <> 0 then begin + IsamOk := False; + IsamError := 10070; + Exit; + end; + ReadMsgHeader := nr = sizeof(TMsgHeader); + end; + + procedure TMsgDatabase.WriteMsgHeader(index: Word; var msghdr: TMsgHeader); + var + ie: TMsgIndexEntry; + nr: Word; + begin + Seek(IndexFile, IndexOffset(index)); + BlockRead(IndexFile, ie, sizeof(TMsgIndexEntry), nr); + if (IoResult <> 0) or (nr <> sizeof(TMsgIndexEntry)) then begin + IsamOk := False; + IsamError := 10070; + Exit; + end; + if ie.MsgNumber <> msghdr.MsgNumber then + {LogFatalError('Message database error - run wcREPAIR', 10010);} + LogFatalError('MsgNumber mismatch, conf='+Long2Str(conf)+ + ' ie='+Long2Str(ie.MsgNumber)+ + ' hdr='+Long2Str(msghdr.MsgNumber), 0); + Seek(DataFile, ie.HeaderOffset); + BlockWrite(DataFile, msghdr, sizeof(TMsgHeader)); + if IoResult <> 0 then begin + IsamError := 10070; + FatalDbError('Error writing message header'); + end; + end; + + procedure TMsgDatabase.UnhookMessage(index: Word; var msghdr: TMsgHeader); + var + tmsghdr: TMsgHeader; + tindex: Word; + tuserconf: PUserWrapper; + userref: Longint; + userrec: PUserRec; + begin + (* + IntegrityCheck('UnhookMessage start', msghdr.DestUserId); + *) + if (msghdr.PrevUnread = msghdr.MsgNumber) and (msghdr.DestUserId > 0) then begin + UserDB^.Lock; + if UserDB^.FindKey(UserIDKey, userref, BuildUserIdKey(msghdr.DestUserId)) then begin + New(userrec); + UserDB^.GetRec(userref, userrec^); + tuserconf := New(PUserWrapper, Init(userrec^)); + tuserconf^.SetFirstUnread(Conf, 0); + Dispose(tuserconf, Done); + Dispose(userrec); + end; + UserDB^.Unlock; + end + else begin + if (msghdr.PrevUnread > msghdr.MsgNumber) and (msghdr.DestUserId > 0) then begin + UserDB^.Lock; + if UserDB^.FindKey(UserIdKey, userref, BuildUserIdKey(msghdr.DestUserId)) then begin + New(userrec); + UserDB^.GetRec(userref, userrec^); + tuserconf := New(PUserWrapper, Init(userrec^)); + tuserconf^.SetFirstUnread(Conf, msghdr.NextUnread); + Dispose(tuserconf, Done); + Dispose(userrec); + end; + UserDB^.Unlock; + end; + tindex := FindMsgIndex(msghdr.PrevUnread, tmsghdr); + if IsamOk and (tmsghdr.NextUnread = msghdr.MsgNumber) then begin + tmsghdr.NextUnread := msghdr.NextUnread; + WriteMsgHeader(tindex, tmsghdr); + end; + tindex := FindMsgIndex(msghdr.NextUnread, tmsghdr); + if IsamOk and (tmsghdr.PrevUnread = msghdr.MsgNumber) then begin + tmsghdr.PrevUnread := msghdr.PrevUnread; + WriteMsgHeader(tindex, tmsghdr); + end; + end; + msghdr.PrevUnread := 0; + msghdr.NextUnread := 0; + WriteMsgHeader(index, msghdr); + (* + IntegrityCheck('UnhookMessage end', msghdr.DestUserId); + *) + end; + + (* + + procedure TMsgDatabase.IntegrityCheck(const where: String; userid: Longint); + + var userref: Longint; + userrec: TUserRec; + tuserconf: PUserWrapper; + first, i, last: Word; + msg: TMsgHeader; + n1, n2: Word; + info: String; + + begin + if (userid = 0) or (MwConfig^.SysopName <> 'MSI SYSOP') then + Exit; + info := '*** '+TodayString('mm/dd/yy')+' '+CurrentTimeString('hh:mm:ss')+' '+ + where+' (Conf='+Long2Str(Conf)+' Uid='+Long2Str(userid)+'): '; + if UserDB^.FindKey(UserIDKey, userref, BuildUserIdKey(userid)) then begin + UserDB^.GetRec(userref, userrec); + tuserconf := New(PUserWrapper, Init(userrec)); + first := tuserconf^.GetFirstUnread(Conf); + Dispose(tuserconf, Done); + if first > 0 then begin + n1 := 0; + i := first; + repeat + FindMsgIndex(i, msg); + if not IsamOk then begin + NoteInFile(info+'IsamOk=False threading forward'); + Break; + end; + Inc(n1); + last := i; + i := msg.NextUnread; + until (i = 0) or (i <= last); + if i = 0 then + NoteInFile(info+'Zero found in forward link'); + n2 := 0; + i := first; + FindMsgIndex(i, msg); + i := msg.PrevUnread; + if i > 0 then begin + repeat + FindMsgIndex(i, msg); + if not IsamOk then begin + NoteInFile(info+'IsamOk=False threading backward'); + Break; + end; + Inc(n2); + last := i; + i := msg.PrevUnread; + until (i = 0) or (i >= last); + end; + if i = 0 then + NoteInFile(info+'Zero found in backward link'); + if n1 <> n2 then + NoteInFile(info+'Unread chain length mismatch'); + end; + end; + end; + + *) + +end. diff --git a/src/wc_sdk/wcmsgex.pas b/src/wc_sdk/wcmsgex.pas new file mode 100755 index 0000000..e4a8775 --- /dev/null +++ b/src/wc_sdk/wcmsgex.pas @@ -0,0 +1,203 @@ +unit WcMsgEX; + +interface + +uses + Dos, + WcType, + Filer, + WcMisc, + WcDb, + WcMsgDb, + WcGlobal; + +type + PExMsgBase = ^TExMsgBase; + TExMsgBase = object + constructor Init; + destructor Done; virtual; + procedure Lock; + procedure Unlock; + function AddMsg(var Msg : TMsgHeader; MsgText : PMsgText; Conf : Word) : Boolean; + procedure MarkMsgRead(conf, num: Word); + procedure ProcessMsgs; + private + MsgFile : File; + LockCount : Word; + end; + +implementation + +type + TExMsgHeader = record + What: (emwAddMsg, emwMarkMsgRead); + Conference: Word; + Msg: TMsgHeader; + end; + +const + MsgExName = 'MSGEX.DAT'; + + constructor TExMsgBase.Init; + begin + LockCount := 0; + Assign(MsgFile, MwConfig.UserDataBasePath+MsgExName); + Reset(MsgFile, 1); + if IoResult <> 0 then + begin + Rewrite(MsgFile, 1); + if IoResult <> 0 then + Fail; + end; + end; + + destructor TExMsgBase.Done; + begin + Close(MsgFile); + end; + + procedure TExMsgBase.Lock; + + var retries: Word; + + begin + if LockCount = 0 then begin + retries := 0; + while not BTIsamLockRecord(0, 1, FileRec(MsgFile).Handle, 768, 64) do begin + IsamDelay(Random(200)); + Inc(retries); + if retries > 50 then + LogFatalError('Error locking message database', IsamError); + WriteTopRight('Lock retry #'+Long2Str(retries)); + end; + end; + Inc(LockCount); + end; + + + procedure TExMsgBase.Unlock; + + begin + Dec(LockCount); + if (LockCount = 0) and not BTIsamUnLockRecord(0, 1, FileRec(MsgFile).Handle) then + LogFatalError('Error unlocking message database', IsamError); + end; + + + function TExMsgBase.AddMsg(var Msg : TMsgHeader; MsgText : PMsgText; Conf : Word) : Boolean; + var + Io : Word; + emh: TExMsgHeader; + begin + AddMsg := False; + emh.What := emwAddMsg; + emh.Conference := Conf; + emh.Msg := Msg; + Lock; + Seek(MsgFile, FileSize(MsgFile)); + Io := IoResult; + if Io <> 0 then + LogFatalError('Error seeking EXMsgBase', Io); + BlockWrite(MsgFile, emh, SizeOf(TExMsgHeader)); + Io := IoResult; + if Io <> 0 then + LogFatalError('Error writing EXMsgBase header', Io); + BlockWrite(MsgFile, Msgtext^, Msg.MsgBytes); + if Io <> 0 then + LogFatalError('Error writing EXMsgBase text', Io); + UnLock; + AddMsg := True; + end; + + + procedure TExMsgBase.MarkMsgRead(conf, num: Word); + + var emh: TExMsgHeader; + Io: Integer; + + begin + emh.What := emwMarkMsgRead; + emh.Conference := conf; + emh.Msg.MsgNumber := num; + Lock; + Seek(MsgFile, FileSize(MsgFile)); + Io := IoResult; + if Io <> 0 then + LogFatalError('Error seeking EXMsgBase', Io); + BlockWrite(MsgFile, emh, SizeOf(TExMsgHeader)); + Io := IoResult; + if Io <> 0 then + LogFatalError('Error writing EXMsgBase header', Io); + UnLock; + end; + + + procedure TExMsgBase.ProcessMsgs; + var + emh : TExMsgHeader; + MsgText : PMsgText; + Io, + Last : Word; + RefNr : LongInt; + + begin + Last := $FFFF; + RefNr := 1; + + New(MsgText); + if MsgText = nil then + LogFatalError('Could not allocate message buffer', 0); + + Seek(MsgFile, 0); + + Io := IoResult; + if Io <> 0 then + LogFatalError('Error seeking EXMsgBase file', Io); + + while not Eof(MsgFile) do + begin + BlockRead(MsgFile, emh, SizeOf(TExMsgHeader)); + Io := IoResult; + if Io <> 0 then + LogFatalError('Error reading EXMsgBase header', Io); + if emh.What = emwAddMsg then begin + BlockRead(MsgFile, MsgText^, emh.Msg.MsgBytes); + Io := IoResult; + if Io <> 0 then + LogFatalError('Error reading EXMsgBase Text', Io); + end; + if emh.Conference <> Last then + begin + if Last <> $FFFF then + MsgDb.Done; + if not MsgDb.Open(emh.Conference, False) then + LogFatalError('Error opening conference '+Long2Str(emh.Conference), IsamError); + Last := emh.Conference; + end; + case emh.What of + emwAddMsg: + MsgDb.AddMsg(RefNr, emh.Msg, MsgText); + emwMarkMsgRead: + begin + refnr := MsgDb.FindMsg(emh.Msg.MsgNumber); + if IsamOk then begin + MsgDb.GetMsgHeader(refnr, emh.Msg); + if not FlagIsSet(emh.Msg.mFlags, mfReceived) then begin + SetFlag(emh.Msg.mFlags, mfReceived); + ClearFlag(emh.Msg.mFlags, mfReceipt); + MsgDb.MarkMsgRead(emh.Msg); + end; + end; + end; + else + LogFatalError('Error in EXMsgBase tag: '+Long2Str(Ord(emh.What)), 0); + end; + end; + + if Last <> $FFFF then + MsgDb.Done; + Dispose(MsgText); + Erase(MsgFile); + end; + +end. \ No newline at end of file diff --git a/src/wc_sdk/wcpagedb.pas b/src/wc_sdk/wcpagedb.pas new file mode 100644 index 0000000..5b76c13 --- /dev/null +++ b/src/wc_sdk/wcpagedb.pas @@ -0,0 +1,340 @@ +unit WcPageDB; + +interface + +uses + WcType, + WcGlobal, + Dos, + Filer, + Crt, + WcMisc; + +type + PSysPage = ^TSysPage; + TSysPage = object + FPage : File; + FText : File; + Err : Word; + CurrentPage : Word; + Active : Word; + LockCount : Word; + constructor Init(const WorkDir : String); + destructor Done(EraseFiles : Boolean); + procedure Lock; + procedure UnLock; + function SendPagePrim(PHdr : TNodePage; Txt : PMsgText) : Boolean; + function SendPageLine(PHdr : TNodePage; Txt : String) : Boolean; + function DisplayPageText(PHdr : TNodePage) : Boolean; + function GetPageHeader(Page : Word; var PageHdr : TNodePage) : Boolean; + function NextPageHdr(var PageHdr : TNodePage) : Boolean; + function LastPageHdr(var PageHdr : TNodePage) : Boolean; + function ActivePages(ForceCheck : Boolean) : Word; + private + function IsamDosErr : Boolean; + end; + +var + PageDb : TSysPage; + +implementation + + constructor TSysPage.Init(const WorkDir : String); + begin + FileMode := ShareMode; + if ExistFile(WorkDir+'\NODEPAGE.DAT') then + begin + Assign(FPage, WorkDir+'\NODEPAGE.DAT'); + Reset(FPage, 1); + if IsamDosErr then + LogFatalError('Error opening '+WorkDir+'\NODEPAGE.DAT.', Err); + + Assign(FText, WorkDir+'\NODETEXT.DAT'); + Reset(FText, 1); + if IsamDosErr then + LogFatalError('Error opening '+WorkDir+'\NODETEXT.DAT.', Err); + + if FileSize(FPage) > 0 then + Active := FileSize(FPage) div SizeOf(TNodePage) + else + Active := 0; + + CurrentPage := $FFFF; + LockCount := 0; + end + else + begin + Assign(FPage, WorkDir+'\NODEPAGE.DAT'); + Rewrite(FPage, 1); + if IsamDosErr then + LogFatalError('Error creating '+WorkDir+'\NODEPAGE.DAT.', Err); + + Assign(FText, WorkDir+'\NODETEXT.DAT'); + Rewrite(FText, 1); + if IsamDosErr then + LogFatalError('Error creating '+WorkDir+'\NODETEXT.DAT.', Err); + + Active := 0; + CurrentPage := $FFFF; + LockCount := 0; + end; + end; + + + destructor TSysPage.Done(EraseFiles : Boolean); + begin + Close(FPage); + IsamDosErr; + if EraseFiles then + Erase(FPage); + IsamDosErr; + Close(FText); + IsamDosErr; + if EraseFiles then + Erase(FText); + IsamDosErr; + end; + + + procedure TSysPage.Lock; + var + Retries : Word; + + begin + if LockCount = 0 then + begin + Retries := 0; + while not BTIsamLockRecord(0, 1, FileRec(FPage).Handle, IsamLockTimeOut, IsamDelayBetwLocks) do + begin + IsamDelay(Random(200)); + Inc(retries); + if Retries > 50 then + LogFatalError('NODEPAGE.DAT', IsamError); + WriteTopRight('Lock retry #'+Long2Str(retries)); + end; + end; + Inc(LockCount); + end; + + + procedure TSysPage.Unlock; + begin + Dec(LockCount); + if LockCount = 0 then begin + if not BTIsamUnLockRecord(0, 1, FileRec(FPage).Handle) then + LogFatalError('Error unlocking NODEPAGE.DAT', IsamError); + end; + end; + + + function TSysPage.SendPageLine(PHdr : TNodePage; Txt : String) : Boolean; + var + FP : Text; + Line : String; + + begin + SendPageLine := False; + if ExistFile(Txt) then + begin + SendPageLine := False; + Delete(Txt, 1, 2); + if ExistFile(Txt) then + begin + Assign(FP, Txt); + Reset(FP); + if IoResult <> 0 then + Exit; + PHdr.PageBytes := 0; + Lock; + PHdr.TextPos := FileSize(FText); + Inc(Active); + PHdr.PageNumber := Active; + Seek(FText, FileSize(FText)); + if IsamDosErr then + LogFatalError('Error seeking NODETEXT.DAT', Err); + repeat + ReadLn(FP, Line); + if Length(Line) > 79 then + Line[0] := #79; + Line := Line + #13; + BlockWrite(FText, Line[1], Length(Line)); + if IsamDosErr then + LogFatalError('Error writing NODETEXT.DAT', Err); + Inc(PHdr.PageBytes, Length(Line)); + until EOF(FP) or (IoResult <> 0); + BlockWrite(FPage, PHdr, SizeOf(TNodePage)); + if IsamDosErr then + LogFatalError('Error writing NODEPAGE.DAT', Err); + Unlock; + Close(FP); + SendPageLine := True; + end; + end + else + begin + PHdr.PageBytes := Length(Txt)+2; + Txt := Txt + #13; + Lock; + Seek(FPage, FileSize(FPage)); + if IsamDosErr then + LogFatalError('Error seeking NODEPAGE.DAT', Err); + PHdr.TextPos := FileSize(FText); + Inc(Active); + PHdr.PageNumber := Active; + BlockWrite(FPage, PHdr, SizeOf(TNodePage)); + if IsamDosErr then + LogFatalError('Error writing NODEPAGE.DAT', Err); + Seek(FText, FileSize(FText)); + if IsamDosErr then + LogFatalError('Error seeking NODETEXT.DAT', Err); + BlockWrite(FText, Txt[1], PHdr.PageBytes); + if IsamDosErr then + LogFatalError('Error writing NODETEXT.DAT', Err); + Unlock; + SendPageLine := True; + end; + end; + + + function TSysPage.SendPagePrim(PHdr : TNodePage; Txt : PMsgText) : Boolean; + begin + SendPagePrim := False; + Lock; + Seek(FPage, FileSize(FPage)); + if IsamDosErr then + LogFatalError('Error seeking NODEPAGE.DAT', Err); + PHdr.TextPos := FileSize(FText); + Inc(Active); + PHdr.PageNumber := Active; + BlockWrite(FPage, PHdr, SizeOf(TNodePage)); + if IsamDosErr then + LogFatalError('Error writing NODEPAGE.DAT', Err); + Seek(FText, FileSize(FText)); + if IsamDosErr then + LogFatalError('Error seeking NODETEXT.DAT', Err); + BlockWrite(FText, Txt^, PHdr.PageBytes); + if IsamDosErr then + LogFatalError('Error writing NODETEXT.DAT', Err); + Unlock; + SendPagePrim := True; + end; + + + function TSysPage.DisplayPageText(PHdr : TNodePage) : Boolean; + var + BlockPos : Word; + Text : PMsgText; + St : String; + + begin + DisplayPageText := False; + + if not GetMemCheck(Text, PHdr.PageBytes) then + begin + NoteError('Not enough memory to read page'); + Exit; + end; + + Lock; + Seek(FText, PHdr.TextPos); + if IsamDosErr then + LogFatalError('Error seeking NODEPAGE.DAT', Err); + BlockRead(FText, Text^, PHdr.PageBytes); + if IsamDosErr then + LogFatalError('Error reading NODEPAGE.DAT', Err); + UnLock; + IsamDosErr; + + St := ''; + + for BlockPos := 0 to PHdr.PageBytes - 1 do + begin + if (Text^[BlockPos] = #13) or (BlockPos = PHdr.PageBytes - 1) then + begin + WriteLn(St); + St := ''; + end + else + St := St + Char(Text^[BlockPos]); + end; + + FreeMemCheck(Text, PHdr.PageBytes); + + DisplayPageText := True; + end; + + + function TSysPage.GetPageHeader(Page : Word; var PageHdr : TNodePage) : Boolean; + begin + GetPageHeader := False; + + if (Page < 0) or (Page >= Active) then + Exit; + + CurrentPage := Page; + + Seek(FPage, Page * SizeOf(TNodePage)); + if IsamDosErr then + LogFatalError('Error seeking NODEPAGE.DAT', Err); + BlockRead(FPage, PageHdr, SizeOf(TNodePage)); + if IsamDosErr then + LogFatalError('Error reading NODEPAGE.DAT', Err); + + GetPageHeader := True; + end; + + + function TSysPage.NextPageHdr(var PageHdr : TNodePage) : Boolean; + begin + NextPageHdr := False; + if CurrentPage = $FFFF then + CurrentPage := 0 + else + Inc(CurrentPage); + if CurrentPage < Active then + begin + Seek(FPage, CurrentPage * SizeOf(TNodePage)); + if IsamDosErr then + LogFatalError('Error seeking NODEPAGE.DAT', Err); + BlockRead(FPage, PageHdr, SizeOf(TNodePage)); + if IsamDosErr then + LogFatalError('Error reading NODEPAGE.DAT', Err); + NextPageHdr := True; + end; + end; + + + function TSysPage.LastPageHdr(var PageHdr : TNodePage) : Boolean; + begin + LastPageHdr := False; + if CurrentPage = 0 then + Exit; + if CurrentPage = $FFFF then + CurrentPage := Active + else + Dec(CurrentPage); + Seek(FPage, CurrentPage * SizeOf(TNodePage)); + if IsamDosErr then + LogFatalError('Error seeking NODEPAGE.DAT', Err); + BlockRead(FPage, PageHdr, SizeOf(TNodePage)); + if IsamDosErr then + LogFatalError('Error reading NODEPAGE.DAT', Err); + LastPageHdr := True; + end; + + + function TSysPage.ActivePages(ForceCheck : Boolean) : Word; + begin + if ForceCheck then + Active := FileSize(FPage) div SizeOf(TNodePage); + ActivePages := Active; + end; + + + function TSysPage.IsamDosErr : Boolean; + begin + Err := IoResult; + IsamDosErr := Err <> 0; + end; + +end. \ No newline at end of file diff --git a/src/wc_sdk/wctrandb.pas b/src/wc_sdk/wctrandb.pas new file mode 100644 index 0000000..6a662ef --- /dev/null +++ b/src/wc_sdk/wctrandb.pas @@ -0,0 +1,108 @@ +unit wcTranDb; +(************************************************************************** + +Transaction Filer Database for wcBILLING version 4.11 +Copyright 1995 Mustang Software Inc. All rights reserved. + +Last Revised 6/10/95 + +Revision 'A' + +Resonsibility: SLR + +**************************************************************************) + +{$I wcdefine.inc} + +{$O+} + +interface +uses + BillGlo, { Contains definition of Transaction record} + Filer, { Included because of IsamError calls} + wcGlobal, { For other globals used like MakeWild} + wctype, { Definition of other types} + wcDB; { TTransactionDatabase is a descendant + of TFileBlock} + +const + trNumberKey = 1; + trUserIdKey = 2; + trTranTypeKey = 3; + trProcessedKey = 4; + + +type + TTransactionDatabase = object(TFileBlock) + constructor Init; + procedure GetCreateInfo(var DataLen : Word; var Keys : Integer; var IID : IsamIndDescr); virtual; + function BuildKey(const Data; Key : Integer) : IsamKeyStr; virtual; + function AddRecord(var RefNr : LongInt; var Data) : Boolean; virtual; + end; + +var + TDB : TTransactionDatabase; + +implementation + + constructor TTransactionDatabase.Init; + begin + if not inherited Init('BILLING\BILLING', MwConfig.DatabaseMode = dbSaveMode, + MwConfig.Network <> wcType.NoNet, + trNumberKey, + SizeOf(TTransactionRec)) then + Fail; + end; + + procedure TTransactionDatabase.GetCreateInfo(var DataLen : Word; var Keys : Integer; var IID : IsamIndDescr); + begin + DataLen := SizeOf(TTransactionRec); + Keys := 4; + IID[trNumberKey].KeyL := 6; {Transaction number key} + IID[trNumberKey].AllowDupK := False; + IID[trUserIdKey].KeyL := 15; {UserId Key} + IID[trUserIdKey].AllowDupK := True; + IID[trTranTypeKey].KeyL := 3; {Transaction type key} + IID[trTranTypeKey].AllowDupK := True; + IID[trProcessedKey].KeyL := 12; {Record been processed?} + IID[trProcessedKey].AllowDupK := True; + end; + + function TTransactionDatabase.BuildKey(const Data; Key : Integer) : IsamKeyStr; + var + Rec : TTransactionRec absolute Data; + + begin + with Rec do + case Key of + 1 : BuildKey := Long2Key(Number); + 2 : BuildKey := Long2Key(UserId)+Word2Key(DT.D)+Long2Key(DT.T); + 3 : BuildKey := Word2Key(Ord(TransactionType)); + 4 : if Processed then + BuildKey := '' + else + BuildKey := Long2Key(UserId)+Long2Key(Number); + end; + end; + + function TTransactionDatabase.AddRecord(var RefNr : LongInt; var Data) : Boolean; + var + rec : TTransactionRec absolute Data; + ref : longint; + ourkey : IsamKeystr; + + begin + Lock; + ClearKey(trNumberKey); + PrevKey(trNumberKey, Ref, OurKey); + if IsamOk then + Ref := Key2Long(OurKey) + else + Ref := 0; + Rec.Number := Ref+1; + Rec.Status := 0; + AddRecord := inherited AddRecord(RefNr, Data); + UnLock; + end; + +end. diff --git a/src/wc_sdk/wctype.pas b/src/wc_sdk/wctype.pas new file mode 100755 index 0000000..0aefec8 --- /dev/null +++ b/src/wc_sdk/wctype.pas @@ -0,0 +1,1236 @@ +{$IFDEF FPC} + {$Mode TP} + {$PackRecords 1} + {$PackEnum 1} + {$H-} +{$ENDIF} +unit WcType; + +(************************************************************************** + +Global record structure for Wildcat! version 4.20 +Copyright 1986,96 Mustang Software Inc. All rights reserved. + +Last Revised 06-01-96 + +Revision 'X' + +Resonsibility: Paul Davis + +**************************************************************************) + +interface + +uses + Dos +{$IFDEF OPRO} + ,OpDate; +{$ELSE} + {$IFDEF TPro} + ,TpDate; + {$ELSE} + ; + +type + Date = Word; + Time = LongInt; + DateTimeRec = record + D : Date; + T : Time; + end; + {$ENDIF} +{$ENDIF} + +{$IFDEF FPC} +{ TP7-compatible path string types for binary-compatible record layout. + FPC Dos unit defines these as String (=String[255] under $H-), but + TP7 uses fixed sizes that match the WC4 binary data files on disk. } +type + DirStr = String[67]; + PathStr = String[79]; + NameStr = String[8]; + ExtStr = String[4]; +{$ENDIF} + +(***** Maximum limits ****************************************************) + +const + MaximumConfs = 32760; + MaximumFiles = 32760; + MaximumMsgs = 65520; + MaximumProfiles = 1000; + MaximumDoors = 1000; + MaximumIdle = 1000; + MaximumLang = 1000; + MaximumGroups = 1000; + +(***** Various bit set types *********************************************) + +type + PNodeInfoBits = ^TNodeInfoBits; + TNodeInfoBits = array [1..32] of Byte; + PArray1000Bits = ^TArray1000Bits; + TArray1000Bits = array [1..126] of Byte; + PArray32768Bits = ^TArray32768Bits; + TArray32768Bits = array [1..4096] of Byte; + +(***** Modem profile file (*.MDM) ****************************************) + +const + mpFixedRate = $01; + mpCtsRtsFlow = $02; + mpDropOnExit = $04; + mpForceARQ = $08; + mpTelnetMDM = $10; + mpForceSPWrd = $20; + +type + TGetBaud = (gbResult1, gbResult2, gbByCR, gbDTE); + TAnswer = (aRing, aResult, aAutoAnswer); + TInterface = (iSerial, iDigiboard, iFossil, iOS2, iNone); + TBaudType = (bNone, b300, b1200, b2400, b4800, b7200, b9600, b12000, + b14400, b16800, b19200, b21600, b24000, b26400, b28800, + b31200, b33600, b38400, b57600, b115200); + +const + BaudNumber : array [TBaudType] of LongInt = (0, 300, 1200, 2400, 4800, 7200, + 9600, 12000, 14400, 16800, 19200, + 21600, 24000, 26400, 28800, 31200, + 33600, 38400, 57600, 115200); + +type + PModemProfilePtr = ^TModemProfile; + TModemProfile = record + Version : Word; + ModemName : String[30]; + InitBaud : LongInt; + CommPort, + CommIrq, + CarrierDelay, + pFlags, + FifoTrigger : Byte; + CommBase, + RingDelay, + DropDtrDelay, + PreLogDelay, + ResultDelay, + ResetDelay : Word; + AnswerPhone : TAnswer; + DetermineBaud : TGetBaud; + InterfaceType : TInterface; + RingStr, + AnswerStr, + CallerIdStr, + ModemReset, + OnHook, + OffHook, + ErrorStr, + ModemInit : String[60]; + BaudStrings : array [1..20] of String[20]; + BaudRates : array [1..20] of LongInt; + DumpStr, + ResetStr, + WriteStr : String[10]; + SetupStr : array [1..3] of String[40]; + Notes : array [1..3] of String[64]; + FifoSend : Byte; + TelnetStr : String[20]; + InactiveWait : Byte; {!!.X} + Reserved : array [1..27] of Byte; + end; + +(***** Makewild file (MAKEWILD.DAT) **************************************) + +const + mwLogOffIfNotVerified = $00000001; + mwSysopDropToDos = $00000002; + mwShowSec = $00000004; + mwUseClearScreens = $00000008; + mwFreeFormPhone = $00000010; + mwEncryptPasswords = $00000020; + mwOverwriteChatFiles = $00000040; + mwLockOutForSecError = $00000080; + mwReserved4 = $00000100; + mwDynamicFileKeys = $00000200; + mwSysopReadPrivate = $00000400; + mwShowUserSec = $00000800; + mwPrinterOnline = $00001000; + mwBulletsOptional = $00002000; + mwTerminateOnDoors = $00004000; + mwAutoId = $00008000; + mwForce8N1 = $00010000; + mwReserved3 = $00020000; + mwCopyOnCD = $00040000; + mwIndexLongDesc = $00080000; + mwAllowLocalUpgrades = $00100000; + mwPreferredChatMode = $00200000; + mwLanguageAtLogon = $00400000; + + mwTCBulletins = $0001; + mwTCNews = $0002; + mwTCFiles = $0004; + mwTCDetailDL = $0008; + mwTCCheckDups = $0010; + mwTCFaxSupport = $0020; + mwTCNetSendPrivate = $0040; + + mwCTUserAliasAllowed = $00000001; + mwCTActionWords = $00000002; + mwCTPaging = $00000004; + mwCTPrivateChan = $00000008; + mwCTChangeTopic = $00000010; + +type + TModerate = (mdAll, mdPrivate, mdPublic, mdNone); + TSwapMethod = (tDisk, tEms, tXms, tNoSwap); + TMonitorType = (sColor, sMono, sAuto); + TSystemAccess = (cOpen, cClosed, cClosedComment, cClosedQuestionnaire); + TDBProtect = (dbNone, dbMarkMode, dbSaveMode); + TScreenBlank = (sbNone, sbBox, sbBlackOut, sbSnake); + TConsoleSec = (csNone, csPassword, csNoConsole); + TSettingSec = (ssYes, ssMessage, ssNo); + TNetSupportType = (NoNet, Novell, MsNet); + TSavePacketLevel = (plNone, plNetStatus, plAll); + TColorMenus = (tAscii, tAnsi, tRIP); + TDriveTable = array [1..26] of Byte; + TOverlayType = (otDisk, otEms, otXms); + TDupUserType = (duNone, duNoneChk, duAllow); + TRipMode = (trNone, trRip, trRipForced); + + + TCBaudLimitRec = record + MaxPacket : Word; + MaxConf : Word; + end; + + TPackerRec = record + Letter : Char; + Description : String[30]; + Extension : String[3]; + PackerExe : String[8]; + PackerCmdLine : String[40]; + UnpackerExe : String[8]; + UnpackerCmdLine : String[40]; + end; + + TExcludeBullRec = record + Conference : Word; + BullNumber : Word; + end; + + PMakeWildRec = ^TMakeWildRec; + TMakeWildRec = record + MWVersion : String[4]; + Revision : Byte; + SysopName : String[25]; + Reserved1 : String[5]; + FirstCall : String[25]; + PacketId : String[8]; + Phone : String[25]; + BBSName : String[30]; + FileDataBasePath, + UserDataBasePath, + NodeInfoPath, + ReservedPath, + BatchFilePath, + ModemFilePath, + ChatFilePath, + LanguagePath : DirStr; + NewuserSec : String[10]; + MonitorType : TMonitorType; + CloseOption : TSystemAccess; + Network : TNetSupportType; + DatabaseMode : TDBProtect; + ScreenBlankMode : TScreenBlank; + ScrollBackBuffer : Word; + ExtLtr : array [1..10] of Char; + ExtUpBatch, + ExtDnBatch, + ExtName : array [1..10] of String[12]; + ExtBatchDriven : array [1..10] of Boolean; + ExtraMemForOverlay, + NodeId, + SecTries : Byte; + MaxFileAreas, + MaxConfAreas, + FirstCallLimit : Word; + MwFlags : LongInt; + DateFormat, + TimeFormat : String[40]; + RegString : String[7]; + FlexEventInactivity : Word; + FlexEventForceTime : Time; + LockDriveTable : TDriveTable; + DefaultExt : ExtStr; + ThumbNailFile : String[12]; + ConsolePassword : String[14]; + ConsoleSec : TConsoleSec; + ChangePhone, + ChangeAlias, + ChangeBDate : TSettingSec; + SwapMethod : TSwapMethod; + Packer : array [1..10] of TPackerRec; + TCCity : String[30]; + TCFlags : Word; + PreScanArea : Word; + SavePacketLevel : TSavePacketLevel; + TCMaxPerBaud1 : array [1..18] of TCBaudLimitRec; + TCExcludeBulls : array [1..40] of TExcludeBullRec; + MaxChannelSize : Word; + ChatTimeOut : Word; + TalkTimeOut : Word; + ChatWaitTime : Byte; + ChatModerate : TModerate; + ChatFlags : LongInt; + ModemProfile : TModemProfile; + HoldOverlay : TOverlayType; + DupUserLevel : TDupUserType; + RipMode : TRipMode; + GroupTable : String[26]; + DefaultGroupName : String[30]; + TCMaxPerBaud2 : array [1..12] of TCBaudLimitRec; + DefConfGroupName : String[25]; + BullFileName, {!!.X} + DLFileName : String[12]; {!!.X} + Reserved : array [1..39] of Byte; + end; + +(***** Security profiles (SECLEVEL.DAT) **********************************) + +type + TSysopAccess = (saNo, saYes, saMaster, saNetStatus); + TRatioAction = (raNothing, raWarn, raNoDownloads); + TMenuItemAccess = array [1..8] of Byte; + TProfileType = (ptFullProfile, ptSecondary); + TUploadType = (utNoDupes, utWarnOfDupe, utIgnore); + +const + pfAscii = $00000001; + pfXmodem = $00000002; + pfXmodemCrc = $00000004; + pfXmodem1k = $00000008; + pfXmodem1kG = $00000010; + pfYmodem = $00000020; + pfYmodemG = $00000040; + pfKermit = $00000080; + pfZmodem = $00000100; + pfExternal1 = $00000200; + pfExternal2 = $00000400; + pfExternal3 = $00000800; + pfExternal4 = $00001000; + pfExternal5 = $00002000; + pfExternal6 = $00004000; + pfExternal7 = $00008000; + pfExternal8 = $00010000; + pfExternal9 = $00020000; + pfExternal10 = $00040000; + + sfFastLogin = $00080000; + sfOverwrite = $00100000; + sfShowPWFiles = $00200000; + sfTCFileAccess = $00400000; + sfUpOverTime = $00800000; + sfDnOverTime = $01000000; + sfNoPassword = $02000000; + sfDistMail = $04000000; + sfModifyUpload = $08000000; + sfNoAuthWrite = $10000000; + sfSecurePword = $20000000; + + cfChatSysop = $0001; + cfActionWords = $0002; + cfUninvite = $0004; + cfPageUsers = $0008; + cfModerator = $0010; + cfChatAlias = $0020; + + sConfRead = $01; + sConfWrite = $02; + sConfJoin = $04; + + sFileList = $01; + sFileDown = $02; + sFileUp = $04; + +type + PSecHeader = ^TSecHeader; + TSecHeader = record + ProfileName : String[10]; + ProfileType : TProfileType; + end; + + PSecRec = ^TSecRec; + TSecRec = object + ProfileName : String[10]; + ProfileType : TProfileType; + ExpiredName : String[10]; + DisplayName : String[8]; + NodeAccess : TNodeInfoBits; + DoorAccess : TArray1000Bits; + MenuItemAccess : TMenuItemAccess; + SysopStatus : TSysopAccess; + RatioAction : TRatioAction; + UploadComp, + MaxRatio : Byte; + Menus : Char; + ChatFlags : Word; + sFlags : LongInt; + ExpireDate : Date; + DailyTimeLimit, + MaxLogon, + VerifyBDate, + VerifyPhone, + MaxDL, + MaxDK, + MaxKRatio, + MaxConfAreas, + MaxFileAreas, + FaxFlags : Word; + DoorProfile : String[10]; + UploadAccess : TUploadType; + BillingProfile : String[8]; + DailyFileReqs : Word; + PassWordChange : Word; {!!.X} + Reserved : array [1..23] of Byte; + end; + +(***** Conference name list (CONFDESC.IX, CONFDESC.UX) *******************) + +type + TConfList = record + ConfName : String[25]; + ConfNum : Word; + end; + +(***** Conference list (CONFDESC.DAT) ************************************) + +const + cfPromptToKillMsg = $0001; + cfHighAscii = $0002; + cfAllowCarbon = $0004; + cfReserved1 = $0008; + cfReserved2 = $0010; + cfReturnReceipt = $0020; + cfLongAddress = $0040; + cfUseAlias = $0080; + cfAllowAttach = $0100; + cfPromptToKillAttach = $0200; + cfShowCtrlLines = $0400; + +type + TMailType = (mtNormalPublicPrivate, + mtNormalPublic, + mtNormalPrivate, + mtFidoNetmail, + mtInternetEmail, + mtInternetNewsgroup); + TValidName = (vnYes, vnNo, vnPrompt); + +const mtAllowPrivate = [mtNormalPublicPrivate, + mtNormalPrivate, + mtFidoNetmail, + mtInternetEmail]; + mtForcePrivate = [mtNormalPrivate, + mtFidoNetmail, + mtInternetEmail]; + +type + PConfDesc = ^TConfDesc; + TConfDesc = record + ConfName, + ConfOp : String[25]; + ConfShortName : String[12]; + ConfMail : TMailType; + DoorAccess : TArray1000Bits; + BullPath, + QuesPath, + MenuPath, + HelpPath, + DisplayPath, + MsgPath, + AttachPath : DirStr; + Reserved1 : Byte; + cFlags, + ConfNumber : Word; + ValidNames : TValidName; + MaxMessages, + MaxFileAreas : Word; + Reserved : array [1..50] of Byte; + end; + +(***** Conf group list (CONFGRP.DAT) *************************************) + + PConfGroup = ^TConfGroup; + TConfGroup = record + GroupName : String[25]; + ConfGrpFlags : LongInt; + MaxConfAreas : Word; + DispFile : String[12]; + Reserved : array[1..87] of Byte; + end; + + PConfGroupList = ^TConfGroupList; + TConfGroupList = record + GroupName : String[25]; + GroupNum : Word; + end; + +(***** File locking file (LOCKPATH.DAT) **********************************) + +type + TPathLock = record + DeviceNumber : Byte; + DevicePath : PathStr; + Reserved : array[1..20] of Byte; + end; + +(***** File area name file (FILEAREA.IX, FILEAREA.UX) ********************) + +type + TFileList = record + AreaName : String[30]; + AreaNumber : Word; + end; + +(***** File area file (FILEAREA.DAT) *************************************) + +const + faExcludeNew = $01; + +type + PFileAreaRec = ^TFileAreaRec; + TFileAreaRec = record + AreaName : String[30]; + AreaPath : DirStr; + FileDataBase : String[8]; + aFlags : Byte; + Reserved : array [1..10] of Byte; + end; + +(***** Language file (LANGDESC.DAT) **************************************) + +type + PLangDesc = ^TLangDesc; + TLangDesc = record + Language : String[8]; + Description : String[73]; + YesChar : Char; + NoChar : Char; + end; + +(***** Door file (DOOR.DAT) **********************************************) + +const + diMultiUser = $01; + diInUse = $02; + diMenuHook = $04; + diSmallSys = $08; + diAliasName = $10; + diTerminate = $20; + +type + TDoor = record + diName : String[20]; + diBat : String[8]; + diDisp : String[8]; + diFlags : Byte; + Reserved : array [1..20] of Byte; + end; + +(***** Idle program data (ILDEPGM.DAT) ***********************************) + +type + PIdleProgram = ^TIdleProgram; + TIdleProgram = record + Name : String[30]; + ShellPath : PathStr; + Password : String[14]; + Reserved : array [1..20] of Byte; + end; + +(***** Master info file (NODEINFO.DAT record 0) **************************) + +type + PMasterInfo = ^TMasterInfo; + TMasterInfo = record + VersionId : String[5]; + ActiveNodes : TNodeInfoBits; + TotalCalls, + TotalUsers, + TotalFiles, + TotalMessages : LongInt; + TempCalls, + TempMsgs, + TempDownloads, + TempUploads : Word; + ReservedWords : array[1..8] of Byte; + TempReset : DateTimeRec; + HighestUserId : LongInt; + ChatCount : Byte; + Reserved : array [1..160] of Byte; + end; + +(***** Nodeinfo file (NODEINFO.DAT) **************************************) + +const + niLptr = $00000001; + niPage = $00000002; + niBell = $00000004; + niKybd = $00000008; + niLocalNext = $00000010; + niScreenWrite = $00000020; + niEventNext = $00000040; + niBringDown = $00000080; + niKillCaller = $00000100; + niPagingSysop = $00000200; + niOnLocally = $00000400; + niMNPConnect = $00000800; + niSysopNext = $00001000; + niUseVgaMode = $00002000; + niCapture = $00004000; + niStayDown = $00008000; + niwcNetable = $00010000; + +type + TNodeStatus = (nsDown, nsUp, nsSigningOn, nsLoggedIn, nsEventProcessing, nsRepair, nsReceiveFax, nsMailRun); + TUserStatus = (usNone, usFileTransfer, usEnteringMsg, usInDoor, usInDOS, usPChat, usDChat); + TSysWindow = (swNoWindow, swSingleWindow, swOrigWindow, swBigWindow); + + PNodeInfo = ^TNodeInfo; + TNodeInfo = record + Security : String[10]; + NodeStatus : TNodeStatus; + UserStatus : TUserStatus; + SysWindow : TSysWindow; + CallersName : String[25]; + From : String[30]; + PrevCaller : String[50]; + UserID : LongInt; + BaudRate : LongInt; + TimeCalled, + PrevLogOff, + TimeOff : DateTimeRec; + RequestNode : Integer; + CallerNumber, + nFlags, + QuoteIndex, + LowestBaud : LongInt; + CurStatus : String[20]; + NumberOfCalls : LongInt; + LockConf1 : LongInt; + LockConf2 : LongInt; + Alias : String[25]; + Reserved : array [1..16] of Byte; + end; + +(***** User database (ALLUSERS.DAT) **************************************) + +const + ufNeverDelete = $00000001; + ufChatPage = $00000002; + ufHotKey = $00000004; + ufLockedOut = $00000008; + ufQuoteOnReply = $00000010; + ufBellAtLogin = $00000020; + ufNoPrivMail = $00000040; + ufNoDelMail = $00000080; + ufTCNoPvtExport = $00000100; + ufTCSendFromYou = $00000200; + ufTCSendNewFiles = $00000400; + ufTCSendNewBulls = $00000800; + ufTCUploadHangup = $00001000; + ufReserved = $00002000; + ufTCScanPrivate = $00004000; + ufTCScanFaxes = $00008000; + ufTCScripts = $00010000; + ufSortedLists = $00020000; + ufCrashMail = $00040000; + ufFileAttach = $00080000; + ufCaptureUser = $00100000; + ufSevenBitAscii = $00200000; + ufTCSmallCtrlDat = $00400000; + ufAutoSpellCheck = $00800000; + ufTCColorBulls = $01000000; + ufDetailedList = $02000000; + +const + cufSysopMail = $01; + cufSelected = $02; + cufLockedOut = $04; + cufTitleOff = $08; + cufPersonalOnly = $10; + cufScanAll = $20; + cufAllAttachs = $40; + +type + TPacketType = (pText, pQwk); + +type + TUserConfRecType = (ucrIndex, ucrData); + + PUserConfData = ^TUserConfData; + TUserConfData = record + cuFlags : Byte; + cuLastRead : Word; + cuFirstUnread : Word; + end; + + PUserConfArray = ^TUserConfPage; + TUserConfArray = array [0..1023] of TUserConfData; + + PUserConfPageHeader = ^TUserConfPageHeader; + TUserConfPageHeader = record + RecLen : Word; + RecType : TUserConfRecType; + UserID : LongInt; + Page : Integer; + This : Longint; + end; + + PUserConfPage = ^TUserConfPage; + TUserConfPage = record + RecLen : Word; + RecType : TUserConfRecType; + UserID : LongInt; + Page : Integer; + This : Longint; + UserConfData : TUserConfArray; + end; + + TUserConfIndex = record + RecLen : Word; + RecType : TUserConfRecType; + offsets : array [0..31] of Longint; + end; + +type + TEditor = (ePrompt, eNormal, eFullScreen); + TMorePrompt = (mpErasePrompt, mpNextLine); + TFileDisplay = (fdSingleLine, fdDoubleLine, fdFull, fdLister); + TExpertiseLevel = (elNovice, elRegular, elExpert); + TSex = (sUnKnown, sMale, sFemale); + TMsgDisplay = (mdScroll, mdClear, mdHeader, mdLister); {!!.X} + TScrnDisplay = (sdNoColor, sdColor, sdRip, sdAuto); + TProtocol = (pAll, pXmodem, pXmodemCRC, pYmodem, pYmodemG, pXmodem1K, + pXmodem1KG, pKermit, pZmodem, pAscii, pExt1, pExt2, pExt3, + pExt4, pExt5, pExt6, pExt7, pExt8, pExt9, pExt10); + + TSecondarys = array[1..5] of String[10]; + + PUserRec = ^TUserRec; + TUserRec = record + Status : LongInt; + UserName : String[25]; + From : String[30]; + Password : String[14]; + UserID : LongInt; + PhoneNumber, + DataNumber, + FaxNumber, + ComputerType : String[15]; + SecLevel : String[10]; + Secondary : TSecondarys; + Company, + Address1, + Address2, + City : String[30]; + State : String[15]; + Zip : String[10]; + Country : String[25]; + Title : String[10]; + Alias : String[25]; + NovellName : String[8]; + Language : String[8]; + Comment : array [1..5] of String[30]; + Sex : TSex; + Editor : TEditor; + MorePrompt : TMorePrompt; + Xpert : TExpertiseLevel; + TransferMethod : TProtocol; + ScreenDisplay : TScrnDisplay; + FileDisplay : TFileDisplay; + MsgDisplay : TMsgDisplay; + LinesPerPage : Byte; + LastCall, + LastNewFiles : DateTimeRec; + ExpireDate, + MemoDate, + UserSince, + BirthDate : Date; + ActiveConf, + MsgsWritten, + Uploads, + Downloads, + TimesOn, + TimeLeft : Word; + UFlags, + DailyDL, + DailyDK, + TotalUK, + TotalDK, + MinutesLogged, + SubScriptionBalance, + NetMailBalance : LongInt; + ReservedByte : Byte; + TCPacket : TPacketType; + TCPacker : Char; + TCMaxPerConf : Word; + TCMaxPerPacket : Word; + TCMaxAttachSize : Word; + UserConfData : Longint; + DefaultGroup : Word; + BillingCredits : LongInt; + DailyFileReqs : Word; + PasswordDays : Word; {!!.X} + Reserved : array [1..40] of Byte; + end; + +(***** Message files (MSGxxx.IX) *****************************************) + +const + mfPrivate = $0001; + mfReceiveable = $0002; + mfReceived = $0004; + mfReceipt = $0008; + mfCarboned = $0010; + mfForwarded = $0020; + mfEchoFlag = $0040; + mfHasReplies = $0100; + mfDeleted = $0200; + mfTagged = $0400; + mfSent = $0800; + mfChgAttach = $1000; + mfForwarding = $2000; + mfNoDelete = $4000; + mfNDAttach = $8000; + +type + TFidoAddress = record + Zone, + Net, + Node, + Point : Word; + end; + + PMsgText = ^TMsgText; + TMsgText = array [0..65519] of Char; + + PMsgHeader = ^TMsgHeader; + TMsgHeader = record + MagicNumber : Longint; + MsgNumber : Word; + Orig : String[70]; + OrigTitle : String[10]; + OrigUserID : LongInt; + Dest : String[70]; + DestTitle : String[10]; + DestUserID : LongInt; + Subject : String[70]; + Network : String[8]; + MsgTime : DateTimeRec; + ReadTime : DateTimeRec; + mFlags : Word; + Reference : Word; + FidoFrom : TFidoAddress; + FidoTo : TFidoAddress; + MsgBytes : Word; + InternalAttach : String[12]; + ExternalAttach : String[12]; + PrevUnread : Word; + NextUnread : Word; + FidoFlags : Word; + Cost : LongInt; + Area : Word; + Reserved : array [1..18] of Byte; + end; + + TMsgIndexHeader = record { must be same size as TMsgIndexEntry } + RecordSize : Word; + ActiveRecords : Word; + NextMsgNumber : Word; + end; + + TMsgIndexEntry = record { must be same size as TMsgIndexHeader } + MsgNumber : Word; + HeaderOffset : Longint; + end; + +(***** Group database (GROUPS.DAT) ***************************************) + +const + grGroupOnline = $0001; + grRequest = $0002; + grSendMsg = $0004; + grGroupHidden = $0008; + grFixedDevice = $0010; + grNoNewScans = $0020; + +type + PGroupHeader = ^TGroupHeader; + TGroupHeader = record + GroupName : String[30]; + FileDataBase : String[8]; + VolumeId : String[11]; + VolumeFile : PathStr; + Location : PathStr; + gFlags : Word; + MaxFileAreas : Word; + LockedCount : Word; + FirstArea : Word; + LastArea : Word; + Reserved : array[1..46{+313}] of Byte; + end; + +(***** Group index (GROUPS.IX/UX) ****************************************) + + TGroupList = record + GroupName : String[30]; + GroupNumber : Word; + end; + +(***** Request database (REQUESTS.DAT) ***********************************) + +const + cqReceived = $0001; + cqDeleted = $0002; + +type + PCDRequest = ^TCDRequest; + TCDRequest = record + Area : Word; + DataBase : String[8]; + Location : PathStr; + FileName : String[12]; + UserID : LongInt; + ReqDate : DateTimeRec; + SentDate : DateTimeRec; + reqFlags : Word; + end; + +(***** CD Rom areas database (AREAS.DAT) *********************************) + +type + PGroupDesc = ^TGroupDesc; + TGroupDesc = record + AreaName : String[30]; + AreaPath : PathStr; + AreaNum : Word; + NewArea : Word; + Fill : array[1..18] of Byte; + end; + +(***** File database (ALLFILES.DAT) **************************************) + +const + fiNeverOverwrite = $0001; + fiNeverDelete = $0002; + fiDontCharge = $0004; + fiUploadInProgress = $0008; + fiOnCD = $0010; + fiOffLine = $0020; + fiFailedScan = $0040; + fiFreeTime = $0080; + +type + PFileMsgText = ^TFileMsgText; + TFileMsgText = array [0..1200] of Byte; + TKeyArray = array [1..6] of String[10]; + + PFileRec = ^TFileRec; + TFileRec = record + Status, + Size : LongInt; + FileName : String[12]; + Password : String[14]; + FileTime, + LastAccessed : DateTimeRec; + Uploader : String[25]; + UploaderID : LongInt; + Desc : String[75]; + MsgBytes, + fFlags, + NumOfAccess, + Cost, + Area : Word; + Keywords : TKeyArray; + StoredPath : PathStr; + MsgText : TFileMsgText; + end; + + PFileHeader = ^TFileHeader; + TFileHeader = record + Status, + Size : LongInt; + FileName : String[12]; + Password : String[14]; + FileTime, + LastAccessed : DateTimeRec; + Uploader : String[25]; + UploaderID : LongInt; + Desc : String[75]; + MsgBytes, + fFlags, + NumOfAccess, + Cost, + Area : Word; + Keywords : TKeyArray; + StoredPath : PathStr; + end; + +(***** Menu file (xxx.MNU) ***********************************************) + +type + TMenuCommand = ( + cmBulletins, + cmDoorMenu, + cmSysopComment, + cmPageSysop, + cmShowHellos, + cmQuestionnaires, + cmLocateUser, + cmChangeSettings, + cmStatistics, + cmUsersList, + cmNewsLetter, + cmWhoIsOnline, + cmReadMessage, + cmScanMessages, + cmEnterMessage, + cmDeleteMessage, + cmCheckMailAtMenu, + cmUpdateConfScans, + cmMailDoor, + cmFullFileInfo, + cmListFilesByArea, + cmDownloadFiles, + cmUploadFiles, + cmListFilesByDate, + cmSearchFiles, + cmFileStats, + cmPersonalStats, + cmViewArcFile, + cmReadAFile, + cmEditMarkList, + cmManageEvents, + cmEditUserRec, + cmReadActLog, + cmEraseActLog, + cmEditFileRec, + cmSysopStatus, + cmEditNodes, + cmSysopDownload, + cmSysopUpload, + cmChangeConference, + cmRunQuesFile, + cmXpertLevel, + cmDumpHelpFile, + cmDisplayMenuFile, + cmDisplayDispFile, + cmDisplayTxtFile, + cmDisplayBulletin, + cmLogoffUser, + cmRunScript, + cmGotoMenu, + cmMenuHook, + cmStackCommands, + cmPageUser, + cmwcCHAT, + cmSelectGroups, + cmGlobalPage, + cmReturnPressed, + cmInvalidCommand + ); + +const + MaxMenuItems = 40; + + mufChangeConf = $01; + mufTopLevel = $02; + +type + PMenuItem = ^TMenuItem; + TMenuItem = record + Selection : Char; + CommandDesc : String[30]; + CommandId : TMenuCommand; + CommandParm : Boolean; + CommandStr : String[40]; + CommandNum : Word; + end; + + PMenuRec = ^TMenuRec; + TMenuRec = record + SecAccess : TArray1000Bits; + MenuFields : Byte; + MenuDesc : String[35]; + MenuFile : String[8]; + ConfNumber : Word; + muFlags : Byte; + MenuItem : array [1..MaxMenuItems] of TMenuItem; + end; + +(***** Event file (EVENTxxx.DAT) *****************************************) + +const + etSun = $01; + etMon = $02; + etTue = $04; + etWed = $08; + etThu = $10; + etFri = $20; + etSat = $40; + +type + TEventMethod = (emFlex, emSoft, emHard); + TEventShell = (esShell, esTerminate); + TEventSchedule = (esHourly, esDaily, esMonthly, esYearly); + TEventAction = (eaNoPage, eaResetStats, eaRunBatch, eaAllPageOff, + eaNodePage, eaDosNext, eaAllPageOn, eaBaudLimit, + eaRunScript, eaBellOn, eaBellOff, eaAllBellOn, + eaAllBellOff, eaNodeDown, eaMailRun); + + PEvent = ^TEvent; + TEvent = record + Method : TEventMethod; + Action : TEventAction; + BaudRate : LongInt; + Active : Boolean; + NextExec, + LastExec : DateTimeRec; + DayBitSet : Byte; + ShellType : TEventShell; + BatchPath : PathStr; + Schedule : TEventSchedule; + HourDelay : Byte; + DayOfMonth : Byte; + Month : Byte; + end; + +(***** Node page file (NODEPAGE.DAT) (PAGETEXT.DAT) **********************) + +const + pfReply = $01; + pfSystem = $02; + pfNoHdr = $04; + +type + PNodePage = ^TNodePage; + TNodePage = record + FromName : String[25]; + FromID : LongInt; + FromNode : Byte; + ToName : String[25]; + ToId : LongInt; + Subject : String[70]; + PageDate : DateTimeRec; + PageNumber : Word; + pFlags : Word; + TextPos : LongInt; + PageBytes : Word; + end; + +(***** Chat file data (CHANNELS.DAT) *************************************) + +type + TChannelStatus = (csNotInUse, csPublic, csPrivate, csModerated, csPriMod); + + PChannelRecord = ^TChannelRecord; + TChannelRecord = record + FName : String[8]; + DispFile : String[8]; + Name : String[25]; + ModName : String[25]; + ActionFile : String[8]; + Topic : String[30]; + ChanStatus : TChannelStatus; + Moderator : Word; + Users : Word; + MaxUsers : Word; + LogChannel : Boolean; + Profanity : Boolean; + SecAccess : TArray1000Bits; + end; + +(***** Action word file (*.ACT) ******************************************) + +type + PActionRecord = ^TActionRecord; + TActionRecord = record + KeyWord : String[10]; + ToOriginator : String[80]; + ToTarget : String[80]; + ThirdPerson : String[80]; + NoTarget : String[80]; + end; + +(**** WcNet Control data (WCDIAL.DAT) ************************************) + +const + mdAllowFreqs = $00000001; + +type + PDialMaster = ^TDialMaster; + TDialMaster = record + SystemName : String[30]; + DialInit : String[30]; + DialString : String[20]; + BusyString : String[20]; + NoCarrier : String[20]; + NoDialTone : String[20]; + LastDialed : Word; + LastDialTime : DateTimeRec; + SystemsDialed : LongInt; + TBytesSent : LongInt; + TMsgsSent : LongInt; + TAttchsSend : LongInt; + MDFlags : LongInt; + FreqHub : String[30]; + ReservedField : array[1..19] of Byte; + end; + +const + dnSendMail = $00000001; + dnGetMail = $00000002; + dnSendFiles = $00000004; + dnGetFiles = $00000008; + dnReqInfo = $00000010; + dnConfInfo = $00000020; + dnFilesErr = $00000040; + dnFreqReq = $00000080; + +type + PDialNode = ^TDialNode; + TDialNode = record + SystemName : String[30]; + SystemNumber : String[30]; + Password : String[14]; + DialAttempts : Word; + TimeLimit : Word; + DialWait : Word; + RetryWait : Word; + HostName : String[8]; + DialFlags : LongInt; + LastDialed : DateTimeRec; + LastConnected : DateTimeRec; + MsgsSent : LongInt; + BytesSent : LongInt; + AttachsSent : LongInt; + FilePointer : Word; + ContainerPath : String[30]; + WaitTime : Word; + SysopName : String[25]; {!!.X} + LastConfDate : DateTimeRec; {!!.X} + ReservedField : array[1..35] of Byte; + end; + +type + PWcNetConf =^TWcNetConf; + TWcNetConf = record + Conference : Word; + RemoteConf : Word; + ConfFlags : LongInt; + end; + +implementation + +end. diff --git a/src/wc_sdk/wcuserdb.pas b/src/wc_sdk/wcuserdb.pas new file mode 100755 index 0000000..76ee14e --- /dev/null +++ b/src/wc_sdk/wcuserdb.pas @@ -0,0 +1,675 @@ +{$IFDEF FPC}{$I-}{$V-}{$ENDIF} +unit WcUserDb; + +interface + +uses + WcMisc, + WcType, + Filer, + BTISBase, + WcGlobal, + WcDb; + +const + {keys for User database} + UserNameKey = 1; + UserSecKey = 2; + UserExpDateKey = 3; + UserAliasKey = 4; + UserIdKey = 5; + UserRealKey = 6; + +type + PUserConfDatabase = ^TUserConfDatabase; + TUserConfDatabase = object + private + constructor Init(PageRecs : Word); + destructor Done; virtual; + procedure GetPage(var UserRec : TUserRec; Page : Word; var ConfPage : TUserConfPage); + procedure SavePage(const UserRec : TUserRec; Page : Word; var ConfPage : TUserConfPage); + private + F : File; + IndexSize : Word; + DataSize : Word; + end; + + PUserDatabase = ^TUserDatabase; + TUserDatabase = object(TFileBlock) + UserConfDb : TUserConfDatabase; + constructor Init; + destructor Done; virtual; + procedure GetCreateInfo(var DataLen : Word; var Keys : Integer; var IID : IsamIndDescr); virtual; + function BuildKey(const Data; Key : Integer) : IsamKeyStr; virtual; +{$IFDEF UserDatabaseAdd} + function AddRecord(var RefNr : LongInt; var Data) : Boolean; virtual; +{$ENDIF} + procedure UpdateRecordID(ID : LongInt; var NewData); + procedure FatalDBError(const S : String); virtual; + procedure LogDBError(const S : String); virtual; + end; + + PUserWrapper = ^TUserWrapper; + TUserWrapper = object + PageSize : Word; + UserPtr : PUserRec; + CurPage : Integer; + ConfPage : TUserConfPage; + constructor Init(var UserRec : TUserRec); + destructor Done; virtual; + procedure SetDirty; + function GetFlags(Conf : Word) : Byte; + function FlagIsSet(Mask : Byte; Conf : Word) : Boolean; + function NextSet(Mask : Byte; Current : Word) : Word; + function PrevSet(Mask : Byte; Current : Word) : Word; + function FirstSet(Mask : Byte) : Word; + function LastSet(Mask : Byte) : Word; + function FlagsSet(Mask : Byte) : Word; + procedure SetAllFlags(Mask : Byte); + procedure ClearAllFlags(Mask : Byte); + procedure ToggleFlag(Mask : Byte; Conf : Word); + function GetLastRead(Conf : Word) : Word; + function GetFirstUnread(Conf : Word) : Word; + procedure SetFlags(Conf : Word; NewFlags : Byte); + procedure SetLastRead(Conf, NewLastRead : Word); + procedure SetFirstUnread(Conf, NewFirstUnread: Word); + procedure SetFlags_LastRead(Conf : Word; NewFlags : Byte; NewLastRead : Word); + function GetConfPage(Conf : Word) : Integer; + procedure LoadConfPage(Conf : Word; ForceLoad : Boolean); + procedure SaveConfPage; + end; + +function SwitchLast(const Name : String) : String; +function BuildUserNameKey(const Name : String; UserID : LongInt) : IsamKeyStr; +function BuildUserIDKey(IDName : LongInt) : IsamKeyStr; + +var + UserDb : PUserDatabase; + UserConfPtr : PUserWrapper; + +const + UserDBOpen : Boolean = False; + +implementation + +type + TUserConfFileHeader = record + TotalConfs: Word; + end; + + +{$IFDEF FPC} + function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean; + begin + LongFlagIsSet := Flags and FlagMask = FlagMask; + end; +{$ELSE} + function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean; + inline($5B/$59/$58/$5A/$21/$D8/$21/$CA/$09/$D0/$74/$02/$B0/$01); +{$ENDIF} + + + function UserConfMaxPages : Word; + const + MaxChunk = 1024; + + begin + UserConfMaxPages := (LongInt(MwConfig^.MaxConfAreas) + MaxChunk - 1) div MaxChunk; + end; + + + constructor TUserConfDatabase.Init(PageRecs : Word); + var + Header : TUserConfFileHeader; + Nr : Word; + Fm : Byte; + + begin + Indexsize := 3 + UserConfMaxPages * SizeOf(Longint); + DataSize := SizeOf(TUserConfPageHeader) + PageRecs * SizeOf(TUserConfData); + Assign(F, MwConfig^.UserDatabasePath+'USERCONF.DAT'); + Fm := FileMode; + FileMode := $42; + Reset(F, 1); + FileMode := Fm; + if IoResult <> 0 then begin + ReWrite(F, 1); + if IoResult <> 0 then + begin + IsamError := 10075; {return Write Error in this case} + Fail; + end; + Header.TotalConfs := MwConfig^.MaxConfAreas; + BlockWrite(F, Header, SizeOf(Header)); + Close(F); + if IoResult = 0 then + {ignore}; + Fm := FileMode; + FileMode := $42; + Reset(F, 1); + FileMode := Fm; + if IoResult <> 0 then + begin + IsamError := 10070; {return Open Error in this case} + Fail; + end; + end; + Seek(F, 0); + BlockRead(F, Header, SizeOf(Header), Nr); + if (IoResult <> 0) or (Nr <> SizeOf(Header)) or (Header.TotalConfs <> MwConfig^.MaxConfAreas) then + begin + Close(F); + if IoResult = 0 then + {ignore}; + IsamError := 9907; {return Error in file size} + Fail; + end; + end; + + + destructor TUserConfDatabase.Done; + begin + Close(f); + if IoResult <> 0 then + {ignore}; + end; + + + procedure TUserConfDatabase.GetPage(var UserRec: TUserRec; Page: Word; var ConfPage: TUserConfPage); + var + Io : Word; + OldUser : PUserRec; + Offsets : ^TUserConfIndex; + Ofs : Longint; + + begin + new(OldUser); + new(Offsets); + if UserRec.UserConfData > 0 then begin + Seek(F, UserRec.UserConfData); + BlockRead(F, Offsets^, IndexSize); + Io := IoResult; + if Io <> 0 then + LogFatalError('I/O Error reading USERCONF.DAT', Io); + end else begin + OldUser^ := Userrec; + UserRec.UserConfData := FileSize(F); + UserDB^.UpdateRecord(OldUser^, UserRec); + FillChar(Offsets^, IndexSize, 0); + Offsets^.RecLen := IndexSize; + Offsets^.RecType := ucrIndex; + Seek(F, UserRec.UserConfData); + BlockWrite(F, Offsets^, IndexSize); + Io := IoResult; + if Io <> 0 then + LogFatalError('I/O Error writing USERCONF.DAT', Io); + { + Commit(F); + } + end; + if Offsets^.Offsets[Page] > 0 then begin + Seek(F, Offsets^.Offsets[Page]); + BlockRead(F, ConfPage, DataSize); + Io := IoResult; + if Io <> 0 then + LogFatalError('I/O Error reading USERCONF.DAT', Io); + if ConfPage.Page <> Page then + LogFatalError('USERCONF.DAT needs repair - run WCREPAIR', 0); + end + else begin + Offsets^.Offsets[Page] := FileSize(F); + Seek(F, UserRec.UserConfData); + BlockWrite(F, Offsets^, IndexSize); + Io := IoResult; + if Io <> 0 then + LogFatalError('I/O Error writing USERCONF.DAT', Io); + Ofs := Offsets^.Offsets[Page]; + FillChar(confpage, SizeOf(ConfPage), 0); + ConfPage.RecLen := DataSize; + ConfPage.RecType := ucrData; + ConfPage.UserID := UserRec.UserID; + ConfPage.Page := Page; + ConfPage.This := Ofs; + Seek(F, Ofs); + BlockWrite(F, ConfPage, DataSize); + Io := IoResult; + if Io <> 0 then + LogFatalError('I/O Error writing USERCONF.DAT', Io); + { + Commit(F); + } + end; + end; + + + procedure TUserConfDatabase.SavePage(const UserRec : TUserRec; Page: Word; var ConfPage: TUserConfPage); + var + Io: Word; + + begin + if ConfPage.Page <> Page then {sanity check} + Exit; + Seek(F, ConfPage.This); + BlockWrite(F, ConfPage, DataSize); + Io := IoResult; + if Io <> 0 then + LogFatalError('I/O Error writing USERCONF.DAT', Io); + end; + + +(**********************************************) + + +{$IFDEF R+} +{$DEFINE rwasplus} +{R-} +{$ENDIF} + function SwitchLast(const Name : String) : String; + var + X, Y : Byte; + + begin + Y := Length(Name); + X := Y; + while (Y > 0) and (Name[Y] <> ' ') do + Dec(Y); + if Y = 0 then + SwitchLast := Name + else + SwitchLast := Copy(Name, Succ(Y), X-Y) + ' ' + Copy(Name, 1, Pred(Y)); + end; +{$IFDEF rwasplus} +{$UNDEF rwasplus} +{$R+} +{$ENDIF} + + + function BuildUserNameKey(const Name : String; UserID : LongInt) : IsamKeyStr; + begin + BuildUserNameKey := Pad(StUpcase(SwitchLast(Name)), 25)+Long2Key(UserID); + end; + + + function BuildUserIDKey(IDName : LongInt) : IsamKeyStr; + begin + BuildUserIDKey := Long2Key(IDName); + end; + + + function UserConfPageRecords : Word; + const + MaxChunk = 1024; + + var + Chunks : Word; + + begin + Chunks := (LongInt(MwConfig^.MaxConfAreas) + MaxChunk - 1) div MaxChunk; + UserConfPageRecords := ((LongInt(MwConfig^.MaxConfAreas) + Chunks - 1) div Chunks); + end; + + + constructor TUserDatabase.Init; + begin + with MwConfig^ do + begin + if not inherited Init(UserDatabasePath+'ALLUSERS', DatabaseMode = dbSaveMode, + Network <> WcType.NoNet, UserIdKey, SizeOf(TUserRec)) then + Fail; + if not UserConfDb.Init(UserConfPageRecords) then + begin + inherited Done; + LogFatalError('Error opening USERCONF.DAT', IsamError); + Fail; + end; + UserDBOpen := True; + end; + end; + + + destructor TUserDatabase.Done; + begin + UserConfDb.Done; + inherited Done; + UserDBOpen := False; + end; + + + procedure TUserDatabase.GetCreateInfo(var DataLen : Word; var Keys : Integer; var IID : IsamIndDescr); + begin + DataLen := SizeOf(TUserRec); + Keys := 6; + IID[1].KeyL := 30; {UserName Key} + IID[1].AllowDupK := False; + IID[2].KeyL := 35; {SecLevel + UserName Key} + IID[2].AllowDupK := True; + IID[3].KeyL := 3; {Expired Date Key} + IID[3].AllowDupK := True; + IID[4].KeyL := 25; {User Alias Key} + IID[4].AllowDupK := False; + IID[5].KeyL := 5; {User ID Key} + IID[5].AllowDupK := False; + IID[6].KeyL := 25; {User Real Name} + IID[6].AllowDupK := True; + end; + + + function TUserDatabase.BuildKey(const Data; Key : Integer) : IsamKeyStr; + var + UserRec : TUserRec absolute Data; + + begin + with UserRec do + case Key of + 1 : BuildKey := BuildUserNameKey(UserName, UserID); + 2 : BuildKey := Pad(SecLevel, 10)+StUpcase(SwitchLast(UserName)); + 3 : BuildKey := Word2Key(ExpireDate); + 4 : if UserRec.Alias = '' then + BuildKey := '' + else + BuildKey := StUpcase(Alias); + 5 : BuildKey := BuildUserIDKey(UserId); + 6 : BuildKey := StUpcase(UserName); + end; + end; + + +{$IFDEF UserDatabaseAdd} + function TUserDatabase.AddRecord(var RefNr : LongInt; var Data) : Boolean; + var + UserRec : TUserRec absolute Data; + ConfPage : TUserConfPage; + RefKey : IsamKeyStr; + UserRef : LongInt; + + begin + AddRecord := False; + Lock; + if MwConfig^.DupUserLevel <> duAllow then + if FindKey(UserRealKey, RefNr, BuildKey(UserRec, UserRealKey)) then + begin + Unlock; + Exit; + end; + Unlock; {we unlock here to prevent deadlock with master file} + ReadMInfo(True); + ClearKey(UserIDKey); + PrevKey(UserIDKey, UserRef, RefKey); + if IsamOk then + UserRef := Key2Long(RefKey) + else + UserRef := 0; + if UserRef > MInfo.HighestUserId then + MInfo.HighestUserId := UserRef + 1 + else + Inc(MInfo.HighestUserId); + WriteMInfo; + Lock; + (* + we now have to recheck the duplicate situation, in weird cases we make + increment the highest user id without adding a new user but this is + required to prevent deadlock situations + *) + if MwConfig^.DupUserLevel <> duAllow then + if FindKey(UserRealKey, RefNr, BuildKey(UserRec, UserRealKey)) then + begin + Unlock; + Exit; + end; + UserRec.UserId := MInfo.HighestUserId; + UserRec.UserConfData := 0; + if inherited AddRecord(RefNr, Data) then + begin + AddRecord := True; + UserConfDb.GetPage(UserRec, 0, ConfPage); + end; + Unlock; + end; +{$ENDIF} + + + procedure TUserDatabase.UpdateRecordID(ID : LongInt; var NewData); + begin + inherited UpdateRecordKey(BuildUserIDKey(ID), NewData); + end; + + + procedure TUserDatabase.FatalDBError(const S : String); + begin + LogFatalError('USERS DATABASE : '+ S, IsamError); + end; + + + procedure TUserDatabase.LogDBError(const S : String); + begin + LogError('USERS DATABASE : '+ S, IsamError); + end; + + +(*********************************************) + + + constructor TUserWrapper.Init(var UserRec : TUserRec); + begin + PageSize := UserConfPageRecords; + UserPtr := @UserRec; + CurPage := -1; + end; + + + destructor TUserWrapper.Done; + begin + end; + + + procedure TUserWrapper.SetDirty; + begin + CurPage := -1; + end; + + + function TUserWrapper.GetFlags(Conf : Word) : Byte; + begin + LoadConfPage(Conf, False); + GetFlags := ConfPage.UserConfData[Conf mod PageSize].cuFlags; + end; + + + function TUserWrapper.GetLastRead(Conf : Word) : Word; + begin + LoadConfPage(Conf, False); + GetLastRead := ConfPage.UserConfData[Conf mod PageSize].cuLastRead; + end; + + + function TUserWrapper.GetFirstUnread(Conf : Word) : Word; + begin + LoadConfPage(Conf, False); + GetFirstUnread := ConfPage.UserConfData[Conf mod PageSize].cuFirstUnread; + end; + + + procedure TUserWrapper.SetFlags(Conf : Word; NewFlags : Byte); + begin + UserDB^.Lock; + LoadConfPage(Conf, True); + ConfPage.UserConfData[Conf mod PageSize].cuFlags := NewFlags; + SaveConfPage; + UserDB^.UnLock; + end; + + + procedure TUserWrapper.SetLastRead(Conf, NewLastRead : Word); + begin + UserDB^.Lock; + LoadConfPage(Conf, True); + ConfPage.UserConfData[Conf mod PageSize].cuLastRead := NewLastRead; + SaveConfPage; + UserDB^.UnLock; + end; + + + procedure TUserWrapper.SetFirstUnread(Conf, NewFirstUnread: Word); + begin + UserDB^.Lock; + LoadConfPage(Conf, True); + ConfPage.UserConfData[Conf mod PageSize].cuFirstUnread := NewFirstUnread; + SaveConfPage; + UserDB^.UnLock; + end; + + + procedure TUserWrapper.SetFlags_LastRead(Conf : Word; NewFlags : Byte; NewLastRead : Word); + begin + UserDB^.Lock; + LoadConfPage(Conf, True); + ConfPage.UserConfData[Conf mod PageSize].cuFlags := NewFlags; + ConfPage.UserConfData[Conf mod PageSize].cuLastRead := NewLastRead; + SaveConfPage; + UserDB^.UnLock; + end; + + + function TUserWrapper.GetConfPage(Conf : Word) : Integer; + begin + GetConfPage := Conf div PageSize; + end; + + + procedure TUserWrapper.LoadConfPage(Conf : Word; ForceLoad : Boolean); + var + LoadPage : Word; + + begin + LoadPage := Conf div PageSize; + if (LoadPage <> CurPage) or ForceLoad then + begin + CurPage := LoadPage; + UserDB^.Lock; + UserDB^.UserConfDb.GetPage(UserPtr^, CurPage, ConfPage); + UserDB^.UnLock; + end; + end; + + + procedure TUserWrapper.SaveConfPage; + begin + if CurPage <> -1 then begin + UserDB^.Lock; + UserDB^.UserConfDb.SavePage(UserPtr^, CurPage, ConfPage); + UserDB^.UnLock; + end; + end; + + + function TUserWrapper.FlagIsSet(Mask : Byte; Conf : Word) : Boolean; + begin + FlagIsSet := GetFlags(Conf) and Mask = Mask; + end; + + + function TUserWrapper.NextSet(Mask : Byte; Current : Word) : Word; + var + I : Word; + + begin + I := Current; + Inc(I); + while (I < MwConfig^.MaxConfAreas) and not FlagIsSet(Mask, I) do + Inc(I); + if I < MwConfig^.MaxConfAreas then + NextSet := I + else + NextSet := NoMoreBits; + end; + + + function TUserWrapper.PrevSet(Mask : Byte; Current: Word) : Word; + var + I : Word; + + begin + I := Current; + Dec(I); + while (I >= 0) and not FlagIsSet(Mask, I) do + Dec(I); + if I >= 0 then + PrevSet := I + else + PrevSet := NoMoreBits; + end; + + + function TUserWrapper.FirstSet(Mask : Byte) : Word; + begin + FirstSet := NextSet(Mask, Word(-1)); + end; + + + function TUserWrapper.LastSet(Mask : Byte) : Word; + begin + LastSet := PrevSet(Mask, MwConfig^.MaxConfAreas); + end; + + + function TUserWrapper.FlagsSet(Mask : Byte) : Word; + var + I, Total : Word; + + begin + Total := 0; + for I := 0 to MwConfig^.MaxConfAreas - 1 do + if FlagIsSet(Mask, I) then + Inc(Total); + FlagsSet := Total; + end; + + + procedure TUserWrapper.SetAllFlags(Mask : Byte); + var + I : Word; + + begin + SetDirty; {!! Needed to make sure we reload from disk before doing + any IO, else we might overwrite changes made by someone + else + } + + for I := 0 to MwConfig^.MaxConfAreas - 1 do + SetFlags(I, GetFlags(I) or Mask); + end; + + + procedure TUserWrapper.ClearAllFlags(Mask : Byte); + var + I : Word; + + begin + SetDirty; {!! Needed to make sure we reload from disk before doing + any IO, else we might overwrite changes made by someone + else + } + for I := 0 to MwConfig^.MaxConfAreas - 1 do + SetFlags(I, GetFlags(I) and not Mask); + end; + + + procedure TUserWrapper.ToggleFlag(Mask : Byte; Conf : Word); + var + Flags : Byte; + + begin + SetDirty; {!! Needed to make sure we reload from disk before doing + any IO, else we might overwrite changes made by someone + else + } + Flags := GetFlags(Conf); + if Flags and Mask = Mask then + Flags := Flags and not Mask + else + Flags := Flags or Mask; + SetFlags(Conf, Flags); + end; + + +end.