paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-06-13 00:58:20 +02:00
Code Issues Packages Projects Releases Wiki Activity
cadf4cc024
fpc/fvision/objects.pas
michael e228c1eeba Initial revision
2000-03-07 08:12:00 +00:00

3215 lines
162 KiB
ObjectPascal
Raw Blame History

{**********************************************************}
{ }
{ System independent clone of OBJECTS.PAS }
{ }
{ Interface Copyright (c) 1992 Borland International }
{ }
{ Parts Copyright (c) 1992,96 by Florian Klaempfl }
{ fnklaemp@cip.ft.uni-erlangen.de }
{ }
{ Parts Copyright (c) 1996 by Frank ZAGO }
{ zago@ecoledoc.ipc.fr }
{ }
{ Parts Copyright (c) 1995 by MH Spiegel }
{ }
{ Parts Copyright (c) 1996, 1997, 1998, 1999 }
{ ldeboer@attglobal.net - primary e-mail address }
{ ldeboer@starwon.com.au - backup e-mail address }
{ }
{****************[ THIS CODE IS FREEWARE ]*****************}
{ }
{ This sourcecode is released for the purpose to }
{ promote the pascal language on all platforms. You may }
{ redistribute it and/or modify with the following }
{ DISCLAIMER. }
{ }
{ This SOURCE CODE is distributed "AS IS" WITHOUT }
{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR }
{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. }
{ }
{*****************[ SUPPORTED PLATFORMS ]******************}
{ 16 and 32 Bit compilers }
{ DOS - Turbo Pascal 7.0 + (16 Bit) }
{ DPMI - Turbo Pascal 7.0 + (16 Bit) }
{ - FPC 0.9912+ (GO32V2) (32 Bit) }
{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) }
{ - Delphi 1.0+ (16 Bit) }
{ WIN95/NT - Delphi 2.0+ (32 Bit) }
{ - Virtual Pascal 2.0+ (32 Bit) }
{ - Speedsoft Sybil 2.0+ (32 Bit) }
{ - FPC 0.9912+ (32 Bit) }
{ OS2 - Virtual Pascal 1.0+ (32 Bit) }
{ - Speed Pascal 1.0+ (32 Bit) }
{ - C'T patch to BP (16 Bit) }
{ }
{*****************[ REVISION HISTORY ]*********************}
{ Version Date Fix }
{ ------- --------- --------------------------------- }
{ 1.00 12 Jun 96 First multi platform release }
{ 1.01 20 Jun 96 Fixes to TCollection }
{ 1.02 07 Aug 96 Fixed TStringCollection.Compare }
{ 1.10 18 Jul 97 Windows 95 support added. }
{ 1.11 21 Aug 97 FPC pascal 0.92 implemented }
{ 1.15 26 Aug 97 TXMSStream compatability added }
{ TEMSStream compatability added }
{ 1.30 29 Aug 97 Platform.inc sort added. }
{ 1.32 02 Sep 97 RegisterTypes completed. }
{ 1.37 04 Sep 97 TStream.Get & Put completed. }
{ 1.40 04 Sep 97 LongMul & LongDiv added. }
{ 1.45 04 Sep 97 Refined and passed all tests. }
{ FPC - bugged on register records! }
{ 1.50 05 May 98 Fixed DOS Access to files, one }
{ version for all intel platforms }
{ (CEC) }
{ 1.60 22 Oct 97 Delphi3 32 bit code added. }
{ 1.70 05 Feb 98 Speed pascal code added. }
{ 1.80 05 May 98 Virtual pascal 2.0 compiler added. }
{ 1.85 10 Sep 98 Checks run & commenting added. }
{ 1.90 03 Nov 98 Fixed for FPC version 0.998 }
{ Only Go32v2 supported no Go32v1 }
{ 1.95 02 Feb 99 Moved some stuff to common.pas }
{ 1.97 28 May 99 Bug fix to TCollection.AtInsert }
{ 1.98 07 Jul 99 Speedsoft SYBIL 2.0 code added. }
{ 1.99 08 Jul 99 Fixed TCollection FirstThat etc. }
{ 2.00 27 Oct 99 All stream read/writes checked. }
{ Delphi3+ memory code to COMMON.PAS }
{ 2.01 03 Nov 99 FPC windows support added. }
{**********************************************************}
UNIT Objects;
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
INTERFACE
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
{====Include file to sort compiler platform out =====================}
{$I Platform.inc}
{====================================================================}
{==== Compiler directives ===========================================}
{$IFNDEF PPC_FPC} { FPC doesn't support these switches }
{$F+} { Force far calls - Used because of the Foreach, FirstThat etc...}
{$A+} { Word Align Data }
{$B-} { Allow short circuit boolean evaluations }
{$O+} { This unit may be overlaid }
{$G+} { 286 Code optimization - if you're on an 8088 get a real computer }
{$E+} { Emulation is on }
{$N-} { No 80x87 code generation }
{$ENDIF}
{$X+} { Extended syntax is ok }
{$R-} { Disable range checking }
{$S-} { Disable Stack Checking }
{$I-} { Disable IO Checking }
{$Q-} { Disable Overflow Checking }
{$V-} { Turn off strict VAR strings }
{====================================================================}
USES
{$IFDEF OS_WINDOWS} { WIN/NT CODE }
{$IFNDEF PPC_SPEED} { NON SPEED COMPILER }
{$IFDEF PPC_FPC} { FPC WINDOWS COMPILER }
Windows, { Standard unit }
{$ELSE} { OTHER COMPILERS }
WinTypes, WinProcs, { Stardard units }
{$ENDIF}
{$ELSE} { SPEEDSOFT COMPILER }
WinBase, WinUser, { Standard unit }
{$ENDIF}
{$ENDIF}
Common, FileIO; { GFV standard units }
{***************************************************************************}
{ PUBLIC CONSTANTS }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ STREAM ERROR STATE MASKS }
{---------------------------------------------------------------------------}
CONST
stOk = 0; { No stream error }
stError = -1; { Access error }
stInitError = -2; { Initialize error }
stReadError = -3; { Stream read error }
stWriteError = -4; { Stream write error }
stGetError = -5; { Get object error }
stPutError = -6; { Put object error }
stSeekError = -7; { Seek error in stream }
stOpenError = -8; { Error opening stream }
{---------------------------------------------------------------------------}
{ STREAM ACCESS MODE CONSTANTS }
{---------------------------------------------------------------------------}
CONST
stCreate = fa_Create; { Create new file }
stOpenRead = fa_OpenRead; { Read access only }
stOpenWrite = fa_OpenWrite; { Write access only }
stOpen = fa_Open; { Read/write access }
{---------------------------------------------------------------------------}
{ TCollection ERROR CODES }
{---------------------------------------------------------------------------}
CONST
coIndexError = -1; { Index out of range }
coOverflow = -2; { Overflow }
{---------------------------------------------------------------------------}
{ VMT HEADER CONSTANT - HOPEFULLY WE CAN DROP THIS LATER }
{---------------------------------------------------------------------------}
{$IFDEF PPC_Virtual} { Virtual is different }
CONST
vmtHeaderSize = 12; { VMT header size }
{$ELSE}
CONST
vmtHeaderSize = 8; { VMT header size }
{$ENDIF}
{---------------------------------------------------------------------------}
{ MAXIUM DATA SIZES }
{---------------------------------------------------------------------------}
CONST
MaxCollectionSize = 65520 DIV SizeOf(Pointer); { Max collection size }
{***************************************************************************}
{ PUBLIC TYPE DEFINITIONS }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ CHARACTER SET }
{---------------------------------------------------------------------------}
TYPE
TCharSet = SET Of Char; { Character set }
PCharSet = ^TCharSet; { Character set ptr }
{---------------------------------------------------------------------------}
{ POINTER TO STRING }
{---------------------------------------------------------------------------}
TYPE
PString = ^String; { String pointer }
{---------------------------------------------------------------------------}
{ DOS FILENAME STRING }
{---------------------------------------------------------------------------}
TYPE
{$IFDEF OS_DOS} { DOS/DPMI DEFINE }
FNameStr = String[79]; { DOS filename }
{$ENDIF}
{$IFDEF OS_WINDOWS} { WIN/NT DEFINE }
FNameStr = PChar; { Windows filename }
{$ENDIF}
{$IFDEF OS_OS2} { OS2 DEFINE }
FNameStr = String; { OS2 filename }
{$ENDIF}
{$IFDEF OS_LINUX} { LINUX DEFINE }
FNameStr = String; { Linux filename }
{$ENDIF}
{$IFDEF OS_AMIGA} { AMIGA DEFINE }
FNameStr = String; { Amiga filename }
{$ENDIF}
{$IFDEF OS_ATARI} { ATARI DEFINE }
FNameStr = String[79]; { Atari filename }
{$ENDIF}
{$IFDEF OS_MAC} { MACINTOSH DEFINE }
FNameStr = String; { Mac filename }
{$ENDIF}
{---------------------------------------------------------------------------}
{ FILE HANDLE SIZE }
{---------------------------------------------------------------------------}
TYPE
{$IFDEF OS_DOS} { DOS DEFINITION }
THandle = Integer; { Handles are 16 bits }
{$ENDIF}
{$IFDEF OS_ATARI} { ATARI DEFINITION }
THandle = Integer; { Handles are 16 bits }
{$ENDIF}
{$IFDEF OS_LINUX} { LINUX DEFINITIONS }
{ values are words, though the OS calls return 32-bit values }
{ to check (CEC) }
THandle = LongInt; { Simulated 32 bits }
{$ENDIF}
{$IFDEF OS_AMIGA} { AMIGA DEFINITIONS }
THandle = LongInt; { Handles are 32 bits }
{$ENDIF}
{$IFDEF OS_WINDOWS} { WIN/NT DEFINITIONS }
THandle = sw_Integer; { Can be either }
{$ENDIF}
{$IFDEF OS_OS2} { OS2 DEFINITIONS }
THandle = sw_Integer; { Can be either }
{$ENDIF}
{$IFDEF OS_MAC} { MACINTOSH DEFINITIONS }
THandle = LongInt; { Handles are 32 bits }
{$ENDIF}
{***************************************************************************}
{ PUBLIC RECORD DEFINITIONS }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ TYPE CONVERSION RECORDS }
{---------------------------------------------------------------------------}
TYPE
WordRec = PACKED RECORD
Lo, Hi: Byte; { Word to bytes }
END;
LongRec = PACKED RECORD
Lo, Hi: Word; { LongInt to words }
END;
PtrRec = PACKED RECORD
Ofs, Seg: Word; { Pointer to words }
END;
{---------------------------------------------------------------------------}
{ TStreamRec RECORD - STREAM OBJECT RECORD }
{---------------------------------------------------------------------------}
TYPE
PStreamRec = ^TStreamRec; { Stream record ptr }
TStreamRec = PACKED RECORD
ObjType: Word; { Object type id }
{$IFDEF BP_VmtLink}
VmtLink: Sw_Word; { VMT link like BP }
{$ELSE}
VmtLink: Pointer; { Delphi3/FPC like VMT }
{$ENDIF}
Load : Pointer; { Object load code }
Store: Pointer; { Object store code }
Next : PStreamRec; { Next stream record }
END;
{***************************************************************************}
{ PUBLIC OBJECT DEFINITIONS }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ TPoint OBJECT - POINT OBJECT }
{---------------------------------------------------------------------------}
TYPE
TPoint = OBJECT
X, Y: Integer;
END;
PPoint = ^TPoint;
{---------------------------------------------------------------------------}
{ TRect OBJECT - RECTANGLE OBJECT }
{---------------------------------------------------------------------------}
TRect = OBJECT
A, B: TPoint; { Corner points }
FUNCTION Empty: Boolean;
FUNCTION Equals (R: TRect): Boolean;
FUNCTION Contains (P: TPoint): Boolean;
PROCEDURE Copy (R: TRect);
PROCEDURE Union (R: TRect);
PROCEDURE Intersect (R: TRect);
PROCEDURE Move (ADX, ADY: Integer);
PROCEDURE Grow (ADX, ADY: Integer);
PROCEDURE Assign (XA, YA, XB, YB: Integer);
END;
PRect = ^TRect;
{---------------------------------------------------------------------------}
{ TObject OBJECT - BASE ANCESTOR OBJECT }
{---------------------------------------------------------------------------}
TYPE
TObject = OBJECT
CONSTRUCTOR Init;
PROCEDURE Free;
DESTRUCTOR Done; Virtual;
END;
PObject = ^TObject;
{ ******************************* REMARK ****************************** }
{ Two new virtual methods have been added to the object in the form of }
{ Close and Open. The main use here is in the Disk Based Descendants }
{ the calls open and close the given file so these objects can be }
{ used like standard files. Two new fields have also been added to }
{ speed up seeks on descendants. All existing code will compile and }
{ work completely normally oblivious to these new methods and fields. }
{ ****************************** END REMARK *** Leon de Boer, 15May96 * }
{---------------------------------------------------------------------------}
{ TStream OBJECT - STREAM ANCESTOR OBJECT }
{---------------------------------------------------------------------------}
TYPE
TStream = OBJECT (TObject)
Status : Integer; { Stream status }
ErrorInfo : Integer; { Stream error info }
StreamSize: LongInt; { Stream current size }
Position : LongInt; { Current position }
FUNCTION Get: PObject;
FUNCTION StrRead: PChar;
FUNCTION GetPos: LongInt; Virtual;
FUNCTION GetSize: LongInt; Virtual;
FUNCTION ReadStr: PString;
PROCEDURE Open (OpenMode: Word); Virtual;
PROCEDURE Close; Virtual;
PROCEDURE Reset;
PROCEDURE Flush; Virtual;
PROCEDURE Truncate; Virtual;
PROCEDURE Put (P: PObject);
PROCEDURE StrWrite (P: PChar);
PROCEDURE WriteStr (P: PString);
PROCEDURE Seek (Pos: LongInt); Virtual;
PROCEDURE Error (Code, Info: Integer); Virtual;
PROCEDURE Read (Var Buf; Count: Word); Virtual;
PROCEDURE Write (Var Buf; Count: Word); Virtual;
PROCEDURE CopyFrom (Var S: TStream; Count: LongInt);
END;
PStream = ^TStream;
{ ******************************* REMARK ****************************** }
{ A few minor changes to this object and an extra field added called }
{ FName which holds an AsciiZ array of the filename this allows the }
{ streams file to be opened and closed like a normal text file. All }
{ existing code should work without any changes. }
{ ****************************** END REMARK *** Leon de Boer, 19May96 * }
{---------------------------------------------------------------------------}
{ TDosStream OBJECT - DOS FILE STREAM OBJECT }
{---------------------------------------------------------------------------}
TYPE
TDosStream = OBJECT (TStream)
Handle: THandle; { DOS file handle }
FName : AsciiZ; { AsciiZ filename }
CONSTRUCTOR Init (FileName: FNameStr; Mode: Word);
DESTRUCTOR Done; Virtual;
PROCEDURE Close; Virtual;
PROCEDURE Truncate; Virtual;
PROCEDURE Seek (Pos: LongInt); Virtual;
PROCEDURE Open (OpenMode: Word); Virtual;
PROCEDURE Read (Var Buf; Count: Word); Virtual;
PROCEDURE Write (Var Buf; Count: Word); Virtual;
END;
PDosStream = ^TDosStream;
{ ******************************* REMARK ****************************** }
{ A few minor changes to this object and an extra field added called }
{ lastmode which holds the read or write condition last using the }
{ speed up buffer which helps speed up the flush, position and size }
{ functions. All existing code should work without any changes. }
{ ****************************** END REMARK *** Leon de Boer, 19May96 * }
{---------------------------------------------------------------------------}
{ TBufStream OBJECT - BUFFERED DOS FILE STREAM }
{---------------------------------------------------------------------------}
TYPE
TBufStream = OBJECT (TDosStream)
LastMode: Byte; { Last buffer mode }
BufSize : Word; { Buffer size }
BufPtr : Word; { Buffer start }
BufEnd : Word; { Buffer end }
Buffer : PByteArray; { Buffer allocated }
CONSTRUCTOR Init (FileName: FNameStr; Mode, Size: Word);
DESTRUCTOR Done; Virtual;
PROCEDURE Close; Virtual;
PROCEDURE Flush; Virtual;
PROCEDURE Truncate; Virtual;
PROCEDURE Seek (Pos: LongInt); Virtual;
PROCEDURE Open (OpenMode: Word); Virtual;
PROCEDURE Read (Var Buf; Count: Word); Virtual;
PROCEDURE Write (Var Buf; Count: Word); Virtual;
END;
PBufStream = ^TBufStream;
{ ******************************* REMARK ****************************** }
{ All the changes here should be completely transparent to existing }
{ code. Basically the memory blocks do not have to be base segments }
{ but this means our list becomes memory blocks rather than segments. }
{ The stream will also expand like the other standard streams!! }
{ ****************************** END REMARK *** Leon de Boer, 19May96 * }
{---------------------------------------------------------------------------}
{ TMemoryStream OBJECT - MEMORY STREAM OBJECT }
{---------------------------------------------------------------------------}
TYPE
TMemoryStream = OBJECT (TStream)
BlkCount: Word; { Number of segments }
BlkSize : Word; { Memory block size }
MemSize : LongInt; { Memory alloc size }
BlkList : PPointerArray; { Memory block list }
CONSTRUCTOR Init (ALimit: LongInt; ABlockSize: Word);
DESTRUCTOR Done; Virtual;
PROCEDURE Truncate; Virtual;
PROCEDURE Read (Var Buf; Count: Word); Virtual;
PROCEDURE Write (Var Buf; Count: Word); Virtual;
PRIVATE
FUNCTION ChangeListSize (ALimit: Word): Boolean;
END;
PMemoryStream = ^TMemoryStream;
{ ******************************* REMARK ****************************** }
{ This object under all but real mode DOS is simple a TMemoryStream }
{ by another name. Under real mode DOS programs it copies the standard }
{ standard EMS stream object as per Borland's original unit. }
{ ****************************** END REMARK *** Leon de Boer, 14Aug98 * }
{---------------------------------------------------------------------------}
{ TEmsStream OBJECT - EMS STREAM OBJECT }
{---------------------------------------------------------------------------}
TYPE
{$IFDEF PROC_Real} { DOS REAL MODE CODE }
TEmsStream = OBJECT (TStream)
Handle : Word; { EMS handle }
PageCount: Word; { Pages allocated }
MemSize : LongInt; { EMS alloc size }
CONSTRUCTOR Init (MinSize, MaxSize: LongInt);
DESTRUCTOR Done; Virtual;
PROCEDURE Truncate; Virtual;
PROCEDURE Read (Var Buf; Count: Word); Virtual;
PROCEDURE Write (Var Buf; Count: Word); Virtual;
END;
{$ELSE} { DPMI/WIN/OS2 CODE }
TEmsStream = OBJECT (TMemoryStream) { Memory stream object }
CONSTRUCTOR Init (MinSize, MaxSize: LongInt);
END;
{$ENDIF}
PEmsStream = ^TEmsStream; { EMS stream pointer }
{ ******************************* REMARK ****************************** }
{ This object under all but real mode DOS is simple a TMemoryStream }
{ by another name. Under real mode DOS programs it is a copy of the }
{ EMS stream object but using XMS, it can replace use of TEMSStream. }
{ ****************************** END REMARK *** Leon de Boer, 14Aug98 * }
{---------------------------------------------------------------------------}
{ TXmsStream OBJECT - XMS STREAM OBJECT }
{---------------------------------------------------------------------------}
TYPE
{$IFDEF PROC_Real} { DOS REAL MODE CODE }
TXmsStream = OBJECT (TStream)
Handle : Word; { XMS handle number }
BlocksUsed: Word; { XMS blocks in use }
MemSize : LongInt; { XMS alloc size }
CONSTRUCTOR Init (MinSize, MaxSize: LongInt);
DESTRUCTOR Done; Virtual;
PROCEDURE Truncate; Virtual;
PROCEDURE Read (Var Buf; Count: Word); Virtual;
PROCEDURE Write (Var Buf; Count: Word); Virtual;
END;
{$ELSE} { DPMI/WIN/NT/OS2 CODE }
TXmsStream = OBJECT (TMemoryStream) { Memory stream object }
CONSTRUCTOR Init (MinSize, MaxSize: LongInt);
END;
{$ENDIF}
PXmsStream = ^TXmsStream; { XMS stream pointer }
TYPE
TItemList = Array [0..MaxCollectionSize - 1] Of Pointer;
PItemList = ^TItemList;
{ ******************************* REMARK ****************************** }
{ The changes here look worse than they are. The Sw_Integer simply }
{ switches between Integers and LongInts if switched between 16 and 32 }
{ bit code. All existing code will compile without any changes. }
{ ****************************** END REMARK *** Leon de Boer, 10May96 * }
{---------------------------------------------------------------------------}
{ TCollection OBJECT - COLLECTION ANCESTOR OBJECT }
{---------------------------------------------------------------------------}
TCollection = OBJECT (TObject)
Items: PItemList; { Item list pointer }
Count: Integer; { Item count }
Limit: Integer; { Item limit count }
Delta: Integer; { Inc delta size }
CONSTRUCTOR Init (ALimit, ADelta: Integer);
CONSTRUCTOR Load (Var S: TStream);
DESTRUCTOR Done; Virtual;
FUNCTION At (Index: Integer): Pointer;
FUNCTION IndexOf (Item: Pointer): Integer; Virtual;
FUNCTION GetItem (Var S: TStream): Pointer; Virtual;
FUNCTION LastThat (Test: Pointer): Pointer;
FUNCTION FirstThat (Test: Pointer): Pointer;
PROCEDURE Pack;
PROCEDURE FreeAll;
PROCEDURE DeleteAll;
PROCEDURE Free (Item: Pointer);
PROCEDURE Insert (Item: Pointer); Virtual;
PROCEDURE Delete (Item: Pointer);
PROCEDURE AtFree (Index: Integer);
PROCEDURE FreeItem (Item: Pointer); Virtual;
PROCEDURE AtDelete (Index: Integer);
PROCEDURE ForEach (Action: Pointer);
PROCEDURE SetLimit (ALimit: Integer); Virtual;
PROCEDURE Error (Code, Info: Integer); Virtual;
PROCEDURE AtPut (Index: Integer; Item: Pointer);
PROCEDURE AtInsert (Index: Integer; Item: Pointer);
PROCEDURE Store (Var S: TStream);
PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual;
END;
PCollection = ^TCollection;
{---------------------------------------------------------------------------}
{ TSortedCollection OBJECT - SORTED COLLECTION ANCESTOR }
{---------------------------------------------------------------------------}
TYPE
TSortedCollection = OBJECT (TCollection)
Duplicates: Boolean; { Duplicates flag }
CONSTRUCTOR Init (ALimit, ADelta: Integer);
CONSTRUCTOR Load (Var S: TStream);
FUNCTION KeyOf (Item: Pointer): Pointer; Virtual;
FUNCTION IndexOf (Item: Pointer): Integer; Virtual;
FUNCTION Compare (Key1, Key2: Pointer): Integer; Virtual;
FUNCTION Search (Key: Pointer; Var Index: Integer): Boolean; Virtual;
PROCEDURE Insert (Item: Pointer); Virtual;
PROCEDURE Store (Var S: TStream);
END;
PSortedCollection = ^TSortedCollection;
{---------------------------------------------------------------------------}
{ TStringCollection OBJECT - STRING COLLECTION OBJECT }
{---------------------------------------------------------------------------}
TYPE
TStringCollection = OBJECT (TSortedCollection)
FUNCTION GetItem (Var S: TStream): Pointer; Virtual;
FUNCTION Compare (Key1, Key2: Pointer): Integer; Virtual;
PROCEDURE FreeItem (Item: Pointer); Virtual;
PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual;
END;
PStringCollection = ^TStringCollection;
{---------------------------------------------------------------------------}
{ TStrCollection OBJECT - STRING COLLECTION OBJECT }
{---------------------------------------------------------------------------}
TYPE
TStrCollection = OBJECT (TSortedCollection)
FUNCTION Compare (Key1, Key2: Pointer): Integer; Virtual;
FUNCTION GetItem (Var S: TStream): Pointer; Virtual;
PROCEDURE FreeItem (Item: Pointer); Virtual;
PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual;
END;
PStrCollection = ^TStrCollection;
{ ******************************* REMARK ****************************** }
{ This is a completely >> NEW << object which holds a collection of }
{ strings but does not alphabetically sort them. It is a very useful }
{ object for insert ordered list boxes! }
{ ****************************** END REMARK *** Leon de Boer, 15May96 * }
{---------------------------------------------------------------------------}
{ TUnSortedStrCollection - UNSORTED STRING COLLECTION OBJECT }
{---------------------------------------------------------------------------}
TYPE
TUnSortedStrCollection = OBJECT (TStringCollection)
PROCEDURE Insert (Item: Pointer); Virtual;
END;
PUnSortedStrCollection = ^TUnSortedStrCollection;
{---------------------------------------------------------------------------}
{ TResourceCollection OBJECT - RESOURCE COLLECTION OBJECT }
{---------------------------------------------------------------------------}
TYPE
TResourceCollection = OBJECT (TStringCollection)
FUNCTION KeyOf (Item: Pointer): Pointer; Virtual;
FUNCTION GetItem (Var S: TStream): Pointer; Virtual;
PROCEDURE FreeItem (Item: Pointer); Virtual;
PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual;
END;
PResourceCollection = ^TResourceCollection;
{---------------------------------------------------------------------------}
{ TResourceFile OBJECT - RESOURCE FILE OBJECT }
{---------------------------------------------------------------------------}
TYPE
TResourceFile = OBJECT (TObject)
Stream : PStream; { File as a stream }
Modified: Boolean; { Modified flag }
CONSTRUCTOR Init (AStream: PStream);
DESTRUCTOR Done; Virtual;
FUNCTION Count: Integer;
FUNCTION KeyAt (I: Integer): String;
FUNCTION Get (Key: String): PObject;
FUNCTION SwitchTo (AStream: PStream; Pack: Boolean): PStream;
PROCEDURE Flush;
PROCEDURE Delete (Key: String);
PROCEDURE Put (Item: PObject; Key: String);
PRIVATE
BasePos: LongInt; { Base position }
IndexPos: LongInt; { Index position }
Index: TResourceCollection; { Index collection }
END;
PResourceFile = ^TResourceFile;
TYPE
TStrIndexRec = PACKED RECORD Key, Count, Offset: Word; END;
TStrIndex = Array [0..9999] Of TStrIndexRec;
PStrIndex = ^TStrIndex;
{---------------------------------------------------------------------------}
{ TStringList OBJECT - STRING LIST OBJECT }
{---------------------------------------------------------------------------}
TStringList = OBJECT (TObject)
CONSTRUCTOR Load (Var S: TStream);
DESTRUCTOR Done; Virtual;
FUNCTION Get (Key: Word): String;
PRIVATE
Stream : PStream;
BasePos : LongInt;
IndexSize: Sw_Word;
Index : PStrIndex;
PROCEDURE ReadStr (Var S: String; Offset, Skip: Word);
END;
PStringList = ^TStringList;
{---------------------------------------------------------------------------}
{ TStrListMaker OBJECT - RESOURCE FILE OBJECT }
{---------------------------------------------------------------------------}
TYPE
TStrListMaker = OBJECT (TObject)
CONSTRUCTOR Init (AStrSize, AIndexSize: Word);
DESTRUCTOR Done; Virtual;
PROCEDURE Put (Key: Word; S: String);
PROCEDURE Store (Var S: TStream);
PRIVATE
StrPos : Sw_Word;
StrSize : Sw_Word;
Strings : PByteArray;
IndexPos : Sw_Word;
IndexSize: Sw_Word;
Index : PStrIndex;
Cur : TStrIndexRec;
PROCEDURE CloseCurrent;
END;
PStrListMaker = ^TStrListMaker;
{***************************************************************************}
{ INTERFACE ROUTINES }
{***************************************************************************}
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ STREAM INTERFACE ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-Abstract-----------------------------------------------------------
Terminates program with a run-time error 211. When implementing
an abstract object type, call Abstract in those virtual methods that
must be overridden in descendant types. This ensures that any
attempt to use instances of the abstract object type will fail.
12Jun96 LdB
---------------------------------------------------------------------}
PROCEDURE Abstract;
{-RegisterObjects----------------------------------------------------
Registers the three standard objects TCollection, TStringCollection
and TStrCollection.
02Sep97 LdB
---------------------------------------------------------------------}
PROCEDURE RegisterObjects;
{-RegisterType-------------------------------------------------------
Registers the given object type with Free Vision's streams, creating
a list of known objects. Streams can only store and return these known
object types. Each registered object needs a unique stream registration
record, of type TStreamRec.
02Sep97 LdB
---------------------------------------------------------------------}
PROCEDURE RegisterType (Var S: TStreamRec);
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ GENERAL FUNCTION INTERFACE ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-LongMul------------------------------------------------------------
Returns the long integer value of X * Y integer values.
10Feb98 LdB
---------------------------------------------------------------------}
FUNCTION LongMul (X, Y: Integer): LongInt;
{-LongDiv------------------------------------------------------------
Returns the integer value of long integer X divided by integer Y.
10Feb98 LdB
---------------------------------------------------------------------}
FUNCTION LongDiv (X: LongInt; Y: Integer): Integer;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ DYNAMIC STRING INTERFACE ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-NewStr-------------------------------------------------------------
Allocates a dynamic string into memory. If S is nil, NewStr returns
a nil pointer, otherwise NewStr allocates Length(S)+1 bytes of memory
containing a copy of S, and returns a pointer to the string.
12Jun96 LdB
---------------------------------------------------------------------}
FUNCTION NewStr (S: String): PString;
{-DisposeStr---------------------------------------------------------
Disposes of a PString allocated by the function NewStr.
12Jun96 LdB
---------------------------------------------------------------------}
PROCEDURE DisposeStr (P: PString);
{***************************************************************************}
{ PUBLIC INITIALIZED VARIABLES }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ INITIALIZED DOS/DPMI/WIN/NT/OS2 PUBLIC VARIABLES }
{---------------------------------------------------------------------------}
CONST
StreamError : Pointer = Nil; { Stream error ptr }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ STREAM REGISTRATION RECORDS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ TCollection STREAM REGISTRATION }
{---------------------------------------------------------------------------}
CONST
RCollection: TStreamRec = (
ObjType: 50; { Register id = 50 }
{$IFDEF BP_VMTLink}
VmtLink: Ofs(TypeOf(TCollection)^); { BP style VMT link }
{$ELSE}
VmtLink: TypeOf(TCollection); { Alt style VMT link }
{$ENDIF}
Load: @TCollection.Load; { Object load method }
Store: @TCollection.Store); { Object store method }
{---------------------------------------------------------------------------}
{ TStringCollection STREAM REGISTRATION }
{---------------------------------------------------------------------------}
CONST
RStringCollection: TStreamRec = (
ObjType: 51; { Register id = 51 }
{$IFDEF BP_VMTLink}
VmtLink: Ofs(TypeOf(TStringCollection)^); { BP style VMT link }
{$ELSE}
VmtLink: TypeOf(TStringCollection); { Alt style VMT link }
{$ENDIF}
Load: @TStringCollection.Load; { Object load method }
Store: @TStringCollection.Store); { Object store method }
{---------------------------------------------------------------------------}
{ TStrCollection STREAM REGISTRATION }
{---------------------------------------------------------------------------}
CONST
RStrCollection: TStreamRec = (
ObjType: 69; { Register id = 69 }
{$IFDEF BP_VMTLink}
VmtLink: Ofs(TypeOf(TStrCollection)^); { BP style VMT link }
{$ELSE}
VmtLink: TypeOf(TStrCollection); { Alt style VMT link }
{$ENDIF}
Load: @TStrCollection.Load; { Object load method }
Store: @TStrCollection.Store); { Object store method }
{---------------------------------------------------------------------------}
{ TStringList STREAM REGISTRATION }
{---------------------------------------------------------------------------}
CONST
RStringList: TStreamRec = (
ObjType: 52; { Register id = 52 }
{$IFDEF BP_VMTLink}
VmtLink: Ofs(TypeOf(TStringList)^); { BP style VMT link }
{$ELSE}
VmtLink: TypeOf(TStringList); { Alt style VMT link }
{$ENDIF}
Load: @TStringList.Load; { Object load method }
Store: Nil); { No store method }
{---------------------------------------------------------------------------}
{ TStrListMaker STREAM REGISTRATION }
{---------------------------------------------------------------------------}
CONST
RStrListMaker: TStreamRec = (
ObjType: 52; { Register id = 52 }
{$IFDEF BP_VMTLink}
VmtLink: Ofs(TypeOf(TStrListMaker)^); { BP style VMT link }
{$ELSE}
VmtLink: TypeOf(TStrListMaker); { Alt style VMT link }
{$ENDIF}
Load: Nil; { No load method }
Store: @TStrListMaker.Store); { Object store method }
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
IMPLEMENTATION
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
{$IFDEF PROC_Real} { DOS REAL MODE CODE }
USES XMSUnit, EMSUnit; { Needs these units }
{$ENDIF}
{$IFNDEF PROC_Real} { NOT DOS REAL CODE }
{$DEFINE NewExeFormat} { New format EXE }
{$ENDIF}
{$IFDEF OS_OS2} { OS2 COMPILERS }
{$IFDEF PPC_Virtual} { VIRTUAL PASCAL UNITS }
USES OS2Base; { Standard unit }
{$ENDIF}
{$IFDEF PPC_Speed} { SPEED PASCAL UNITS }
USES BseDos, Os2Def; { Standard units }
{$ENDIF}
{$IFDEF PPC_BPOS2} { C'T PATCH TO BP UNITS }
USES DosTypes, DosProcs; { Standard units }
TYPE FILEFINDBUF = TFILEFINDBUF; { Type correction }
{$ENDIF}
{$ENDIF}
{***************************************************************************}
{ PRIVATE TYPE DEFINITIONS }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ FRAME POINTER SIZE SWITCH TYPE }
{---------------------------------------------------------------------------}
TYPE
FramePointer = sw_Word; { Frame pointer }
{ ******************************* REMARK ****************************** }
{ This TYPECAST is serverely COMPILER SPECIFIC if you have a different }
{ compiler you will probably have to work this out. }
{ ****************************** END REMARK *** Leon de Boer, 08Jul99 * }
{---------------------------------------------------------------------------}
{ POINTER LOCAl FUNCTION DEFINITION SWITCH }
{---------------------------------------------------------------------------}
TYPE
{$IFDEF PPC_VIRTUAL} { VIRTUAL PASCAL }
FuncCallPtr = FUNCTION (Param1: Pointer): Boolean;
{$ELSE} { OTHER COMPILERS }
{$IFNDEF PPC_FPC} { NON FPC COMPILERS }
FuncCallPtr = FUNCTION (Param1: Pointer; _EBP: FramePointer): Boolean;
{$ELSE} { FPC COMPILER }
FuncCallPtr = FUNCTION (_EBP: FramePointer; Param1: Pointer): Boolean;
{$ENDIF}
{$ENDIF}
{***************************************************************************}
{ PRIVATE INITIALIZED VARIABLES }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ INITIALIZED DOS/DPMI/WIN/NT/OS2 PRIVATE VARIABLES }
{---------------------------------------------------------------------------}
CONST
StreamTypes: PStreamRec = Nil; { Stream types reg }
{***************************************************************************}
{ PRIVATE INTERNAL ROUTINES }
{***************************************************************************}
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ PRIVATE INTERNAL DOS/DPMI/WIN/NT/OS2 ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ ******************************* REMARK ****************************** }
{ This routine is serverely COMPILER SPECIFIC if you have a different }
{ compiler you will probably have to work this out. }
{ ****************************** END REMARK *** Leon de Boer, 08Jul99 * }
{---------------------------------------------------------------------------}
{ PrevFramePtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jul99 LdB }
{---------------------------------------------------------------------------}
FUNCTION PrevFramePtr: FramePointer; ASSEMBLER;
{$IFNDEF PPC_FPC} { NON FPC COMPILER }
ASM
{$IFDEF BIT_16} { 16 BIT CODE }
MOV AX, [BP]; { Load AX from BP }
{$IFDEF OS_WINDOWS} { WIN 16 BIT CODE }
AND AL, 0FEH; { Windows make even }
{$ENDIF}
{$IFDEF OS_OS2} { OS2 16 BIT CODE }
AND AL, 0FEH; { OS2 make even }
{$ENDIF}
{$ENDIF}
{$IFDEF BIT_32} { 32 BIT CODE }
MOV EAX, [EBP]; { Get previous frame }
{$ENDIF}
END;
{$ELSE} { FPC COMPILER }
ASM
{$IFDEF i386} { 80x PROCESSOR }
MOVL (%EBP), %EAX; { Get previous frame }
{$ENDIF}
{$IFDEF m68k} { 68x PROCESSOR }
MOVE.L A6, D0; { Get previous frame }
{$ENDIF}
END ['EAX'];
{$ENDIF}
{ ******************************* REMARK ****************************** }
{ This routine is serverely COMPILER SPECIFIC if you have a different }
{ compiler you will probably have to work this out. }
{ ****************************** END REMARK *** Leon de Boer, 08Jul99 * }
{---------------------------------------------------------------------------}
{ CallPointerLocal -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jul99 LdB }
{---------------------------------------------------------------------------}
{$IFDEF PPC_VIRTUAL} { VIRTUAL COMPILER }
FUNCTION CallTestLocal (Func: Pointer; Param1: Pointer): Boolean;
BEGIN
CallTestLocal := FuncCallPtr(Func)(Param1); { Function call to ptr }
END;
{$ELSE} { OTHER COMPILERS }
FUNCTION CallTestLocal (Func: Pointer; Frame: FramePointer;
Param1: Pointer): Boolean;
BEGIN
{$IFNDEF PPC_FPC} { NON FPC COMPILERS }
CallTestLocal := FuncCallPtr(Func)(Param1, Frame); { Function call to ptr }
{$ELSE} { FPC COMPILER }
CallTestLocal := FuncCallPtr(Func)(Frame, Param1); { Function call to ptr }
{$ENDIF}
END;
{$ENDIF}
{---------------------------------------------------------------------------}
{ RegisterError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Jun96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE RegisterError;
BEGIN
RunError(212); { Register error }
END;
{***************************************************************************}
{ OBJECT METHODS }
{***************************************************************************}
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TRect OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
PROCEDURE CheckEmpty (Var Rect: TRect);
BEGIN
With Rect Do Begin
If (A.X >= B.X) OR (A.Y >= B.Y) Then Begin { Zero or reversed }
A.X := 0; { Clear a.x }
A.Y := 0; { Clear a.y }
B.X := 0; { Clear b.x }
B.Y := 0; { Clear b.y }
End;
End;
END;
{--TRect--------------------------------------------------------------------}
{ Empty -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TRect.Empty: Boolean;
BEGIN
Empty := (A.X >= B.X) OR (A.Y >= B.Y); { Empty result }
END;
{--TRect--------------------------------------------------------------------}
{ Equals -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TRect.Equals (R: TRect): Boolean;
BEGIN
Equals := (A.X = R.A.X) AND (A.Y = R.A.Y) AND
(B.X = R.B.X) AND (B.Y = R.B.Y); { Equals result }
END;
{--TRect--------------------------------------------------------------------}
{ Contains -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TRect.Contains (P: TPoint): Boolean;
BEGIN
Contains := (P.X >= A.X) AND (P.X <= B.X) AND
(P.Y >= A.Y) AND (P.Y <= B.Y); { Contains result }
END;
{--TRect--------------------------------------------------------------------}
{ Copy -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TRect.Copy (R: TRect);
BEGIN
A := R.A; { Copy point a }
B := R.B; { Copy point b }
END;
{--TRect--------------------------------------------------------------------}
{ Union -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TRect.Union (R: TRect);
BEGIN
If (R.A.X < A.X) Then A.X := R.A.X; { Take if smaller }
If (R.A.Y < A.Y) Then A.Y := R.A.Y; { Take if smaller }
If (R.B.X > B.X) Then B.X := R.B.X; { Take if larger }
If (R.B.Y > B.Y) Then B.Y := R.B.Y; { Take if larger }
END;
{--TRect--------------------------------------------------------------------}
{ Intersect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TRect.Intersect (R: TRect);
BEGIN
If (R.A.X > A.X) Then A.X := R.A.X; { Take if larger }
If (R.A.Y > A.Y) Then A.Y := R.A.Y; { Take if larger }
If (R.B.X < B.X) Then B.X := R.B.X; { Take if smaller }
If (R.B.Y < B.Y) Then B.Y := R.B.Y; { Take if smaller }
CheckEmpty(Self); { Check if empty }
END;
{--TRect--------------------------------------------------------------------}
{ Move -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TRect.Move (ADX, ADY: Integer);
BEGIN
Inc(A.X, ADX); { Adjust A.X }
Inc(A.Y, ADY); { Adjust A.Y }
Inc(B.X, ADX); { Adjust B.X }
Inc(B.Y, ADY); { Adjust B.Y }
END;
{--TRect--------------------------------------------------------------------}
{ Grow -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TRect.Grow (ADX, ADY: Integer);
BEGIN
Dec(A.X, ADX); { Adjust A.X }
Dec(A.Y, ADY); { Adjust A.Y }
Inc(B.X, ADX); { Adjust B.X }
Inc(B.Y, ADY); { Adjust B.Y }
CheckEmpty(Self); { Check if empty }
END;
{--TRect--------------------------------------------------------------------}
{ Assign -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TRect.Assign (XA, YA, XB, YB: Integer);
BEGIN
A.X := XA; { Hold A.X value }
A.Y := YA; { Hold A.Y value }
B.X := XB; { Hold B.X value }
B.Y := YB; { Hold B.Y value }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TObject OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
TYPE
DummyObject = OBJECT (TObject) { Internal object }
Data: RECORD END; { Helps size VMT link }
END;
{ ******************************* REMARK ****************************** }
{ I Prefer this code because it self sizes VMT link rather than using a }
{ fixed record structure thus it should work on all compilers without a }
{ specific record to match each compiler. }
{ ****************************** END REMARK *** Leon de Boer, 10May96 * }
{--TObject------------------------------------------------------------------}
{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jul99 LdB }
{---------------------------------------------------------------------------}
CONSTRUCTOR TObject.Init;
VAR LinkSize: LongInt; Dummy: DummyObject; P: Pointer;
BEGIN
LinkSize := LongInt(@Dummy.Data)-LongInt(@Dummy); { Calc VMT link size }
P := Pointer(LongInt(@Self)+LinkSize); { Pointer to data }
FillChar(P^, SizeOf(Self)-LinkSize, #0); { Clear data fields }
END;
{--TObject------------------------------------------------------------------}
{ Free -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TObject.Free;
BEGIN
Dispose(PObject(@Self), Done); { Dispose of self }
END;
{--TObject------------------------------------------------------------------}
{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
DESTRUCTOR TObject.Done;
BEGIN { Abstract method }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TStream OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TStream------------------------------------------------------------------}
{ Get -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14Aug98 LdB }
{---------------------------------------------------------------------------}
FUNCTION TStream.Get: PObject;
TYPE LoadPtr = FUNCTION (Var S: TStream; Link: Sw_Word; Iv: Pointer): PObject;
VAR ObjType: Word; P: PStreamRec;
BEGIN
ObjType := 0; { Zero the value }
Read(ObjType, 2); { Read object type }
If (ObjType <> 0) Then Begin { Object registered }
P := StreamTypes; { Current reg list }
While (P <> Nil) AND (P^.ObjType <> ObjType) { Find object type OR }
Do P := P^.Next; { Find end of chain }
If (P = Nil) Then Begin { Not registered }
Error(stGetError, ObjType); { Obj not registered }
Get := Nil; { Return nil pointer }
End Else
{$IFDEF BP_VMTLink} { BP like VMT link }
Get := LoadPtr(P^.Load)(Self, P^.VMTLink, Nil) { Call constructor }
{$ELSE} { FPC/DELPHI3 VMT link }
Get := LoadPtr(P^.Load)(Self,
Sw_Word(P^.VMTLink^), Nil) { Call constructor }
{$ENDIF}
End Else Get := Nil; { Return nil pointer }
END;
{--TStream------------------------------------------------------------------}
{ StrRead -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TStream.StrRead: PChar;
VAR W: Word; P: PChar;
BEGIN
W := 0; { Zero the value }
Read(W, 2); { Read string length }
If (W = 0) Then StrRead := Nil Else Begin { Check for empty }
If (MaxAvail >= (W+1)) Then Begin { Check avail memory }
GetMem(P, W + 1); { Allocate memory }
Read(P[0], W); { Read the data }
P[W] := #0; { Terminate with #0 }
End Else P := Nil; { Not enough memory }
StrRead := P; { PChar returned }
End;
END;
{--TStream------------------------------------------------------------------}
{ ReadStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Aug98 LdB }
{---------------------------------------------------------------------------}
FUNCTION TStream.ReadStr: PString;
VAR B: Byte; P: PString;
BEGIN
Read(B, 1); { Read string length }
If (B > 0) AND (MaxAvail >= (B+1)) Then Begin { Check enough memory }
GetMem(P, B + 1); { Allocate memory }
{$IFDEF PPC_DELPHI3} { DELPHI 3+ COMPILER }
SetLength(P^, B); { Hold new length }
{$ELSE} { OTHER COMPILERS }
P^[0] := Chr(B); { Hold new length }
{$ENDIF}
Read(P^[1], B); { Read string data }
ReadStr := P; { Return string ptr }
End Else ReadStr := Nil;
END;
{--TStream------------------------------------------------------------------}
{ GetPos -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TStream.GetPos: LongInt;
BEGIN
If (Status = stOk) Then GetPos := Position { Return position }
Else GetPos := -1; { Stream in error }
END;
{--TStream------------------------------------------------------------------}
{ GetSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TStream.GetSize: LongInt;
BEGIN
If (Status = stOk) Then GetSize := StreamSize { Return stream size }
Else GetSize := -1; { Stream in error }
END;
{--TStream------------------------------------------------------------------}
{ Close -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStream.Close;
BEGIN { Abstract method }
END;
{--TStream------------------------------------------------------------------}
{ Reset -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStream.Reset;
BEGIN
Status := 0; { Clear status }
ErrorInfo := 0; { Clear error info }
END;
{--TStream------------------------------------------------------------------}
{ Flush -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStream.Flush;
BEGIN { Abstract method }
END;
{--TStream------------------------------------------------------------------}
{ Truncate -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStream.Truncate;
BEGIN
Abstract; { Abstract error }
END;
{--TStream------------------------------------------------------------------}
{ Get -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14Aug98 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStream.Put (P: PObject);
TYPE StorePtr = PROCEDURE (Var S: TStream; AnObject: PObject);
VAR ObjType: Word; Link: Sw_Word; Q: PStreamRec; VmtPtr: ^Sw_Word;
BEGIN
ObjType := 0; { Set objtype to zero }
If (P <> Nil) Then Begin { Non nil object }
VmtPtr := Pointer(P); { Xfer object to ptr }
Link := VmtPtr^; { VMT link }
If (Link <> 0) Then Begin { We have a VMT link }
Q := StreamTypes; { Current reg list }
{$IFDEF BP_VMTLink} { BP like VMT link }
While (Q <> Nil) AND (Q^.VMTLink <> Link) { Find link match OR }
{$ELSE} { FPC/DELHI3 VMT link }
While (Q <> Nil) AND (Sw_Word(Q^.VMTLink^) <>
Link) { Find link match OR }
{$ENDIF}
Do Q := Q^.Next; { Find end of chain }
If (Q = Nil) Then Begin { End of chain found }
Error(stPutError, 0); { Not registered error }
Exit; { Now exit }
End Else ObjType := Q^.ObjType; { Update object type }
End;
End;
Write(ObjType, 2); { Write object type }
If (ObjType <> 0) Then { Registered object }
StorePtr(Q^.Store)(Self, P); { Store object }
END;
{--TStream------------------------------------------------------------------}
{ Seek -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStream.Seek (Pos: LongInt);
BEGIN
If (Status = stOk) Then Begin { Check status }
If (Pos < 0) Then Pos := 0; { Remove negatives }
If (Pos <= StreamSize) Then Position := Pos { If valid set pos }
Else Error(stSeekError, Pos); { Position error }
End;
END;
{--TStream------------------------------------------------------------------}
{ StrWrite -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStream.StrWrite (P: PChar);
VAR W: Word; Q: PByteArray;
BEGIN
W := 0; { Preset zero size }
Q := PByteArray(P); { Transfer type }
If (Q <> Nil) Then While (Q^[W] <> 0) Do Inc(W); { PChar length }
Write(W, SizeOf(W)); { Store length }
If (P <> Nil) Then Write(P[0], W); { Write data }
END;
{--TStream------------------------------------------------------------------}
{ WriteStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStream.WriteStr (P: PString);
CONST Empty: String[1] = '';
BEGIN
If (P <> Nil) Then Write(P^, Length(P^) + 1) { Write string }
Else Write(Empty, 1); { Write empty string }
END;
{--TStream------------------------------------------------------------------}
{ Open -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStream.Open (OpenMode: Word);
BEGIN { Abstract method }
END;
{--TStream------------------------------------------------------------------}
{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStream.Error (Code, Info: Integer);
TYPE TErrorProc = Procedure (Var S: TStream);
BEGIN
Status := Code; { Hold error code }
ErrorInfo := Info; { Hold error info }
If (StreamError <> Nil) Then
TErrorProc(StreamError)(Self); { Call error ptr }
END;
{--TStream------------------------------------------------------------------}
{ Read -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStream.Read (Var Buf; Count: Word);
BEGIN
Abstract; { Abstract error }
END;
{--TStream------------------------------------------------------------------}
{ Write -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStream.Write (Var Buf; Count: Word);
BEGIN
Abstract; { Abstract error }
END;
{--TStream------------------------------------------------------------------}
{ CopyFrom -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStream.CopyFrom (Var S: TStream; Count: LongInt);
VAR W: Word; Buffer: Array[0..1023] of Byte;
BEGIN
While (Count > 0) Do Begin
If (Count > SizeOf(Buffer)) Then { To much data }
W := SizeOf(Buffer) Else W := Count; { Size to transfer }
S.Read(Buffer, W); { Read from stream }
Write(Buffer, W); { Write to stream }
Dec(Count, W); { Dec write count }
End;
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TDosStream OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TDosStream---------------------------------------------------------------}
{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jul99 LdB }
{---------------------------------------------------------------------------}
CONSTRUCTOR TDosStream.Init (FileName: FNameStr; Mode: Word);
VAR Success: Integer; {$IFDEF OS_OS2} Info: FILEFINDBUF; {$ENDIF}
BEGIN
Inherited Init; { Call ancestor }
{$IFDEF OS_WINDOWS} { WIN/NT CODE }
{$IFDEF BIT_16} { 16 BIT WINDOWS CODE }
AnsiToOEM(FileName, FName); { Ansi to OEM }
{$ENDIF}
{$IFDEF BIT_32} { 32 BIT WINDOWS CODE }
{$IFNDEF PPC_SPEED} { NON SPEED COMPILER }
CharToOEM(FileName, FName); { Ansi to OEM }
{$ELSE} { SPEEDSOFT SYBIL 2+ }
CharToOEM(CString(FileName), CString(FName)); { Ansi to OEM }
{$ENDIF}
{$ENDIF}
{$ELSE} { DOS/DPMI/OS2 CODE }
FileName := FileName+#0; { Make asciiz }
Move(FileName[1], FName, Length(FileName)); { Create asciiz name }
{$ENDIF}
Handle := FileOpen(FName, Mode); { Open the file }
If (Handle <> 0) Then Begin { Handle valid }
Success := SetFilePos(Handle, 0, 2, StreamSize); { Locate end of file }
If (Success = 0) Then
Success := SetFilePos(Handle, 0, 0, Position); { Reset to file start }
End Else Success := 103; { Open file failed }
If (Handle = 0) OR (Success <> 0) Then Begin { Open failed }
Handle := -1; { Reset invalid handle }
Error(stInitError, Success); { Call stream error }
End;
END;
{--TDosStream---------------------------------------------------------------}
{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 16May96 LdB }
{---------------------------------------------------------------------------}
DESTRUCTOR TDosStream.Done;
BEGIN
If (Handle <> -1) Then FileClose(Handle); { Close the file }
Inherited Done; { Call ancestor }
END;
{--TDosStream---------------------------------------------------------------}
{ Close -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 16May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TDosStream.Close;
BEGIN
If (Handle <> -1) Then FileClose(Handle); { Close the file }
Position := 0; { Zero the position }
Handle := -1; { Handle now invalid }
END;
{--TDosStream---------------------------------------------------------------}
{ Truncate -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 16May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TDosStream.Truncate;
VAR Success: Integer;
BEGIN
If (Status = stOk) Then Begin { Check status okay }
Success := SetFileSize(Handle, Position); { Truncate file }
If (Success = 0) Then StreamSize := Position { Adjust size }
Else Error(stError, Success); { Identify error }
End;
END;
{--TDosStream---------------------------------------------------------------}
{ Seek -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 16May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TDosStream.Seek (Pos: LongInt);
VAR Success: Integer; Li: LongInt;
BEGIN
If (Status = stOk) Then Begin { Check status okay }
If (Pos < 0) Then Pos := 0; { Negatives removed }
If (Handle = -1) Then Success := 103 Else { File not open }
Success := SetFilePos(Handle, Pos, 0, Li); { Set file position }
If ((Success = -1) OR (Li <> Pos)) Then Begin { We have an error }
If (Success = -1) Then Error(stSeekError, 0) { General seek error }
Else Error(stSeekError, Success); { Specific seek error }
End Else Position := Li; { Adjust position }
End;
END;
{--TDosStream---------------------------------------------------------------}
{ Open -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 16May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TDosStream.Open (OpenMode: Word);
BEGIN
If (Status = stOk) Then Begin { Check status okay }
If (Handle = -1) Then Begin { File not open }
Handle := FileOpen(FName, OpenMode); { Open the file }
Position := 0; { Reset position }
If (Handle = 0) Then Begin { File open failed }
Handle := -1; { Reset handle }
Error(stOpenError, 103); { Call stream error }
End;
End Else Error(stOpenError, 104); { File already open }
End;
END;
{--TDosStream---------------------------------------------------------------}
{ Read -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TDosStream.Read (Var Buf; Count: Word);
VAR Success: Integer; Ri, W: Word; Moved: Sw_Word; P: PByteArray;
BEGIN
If (Position + Count > StreamSize) Then { Insufficient data }
Error(stReadError, 0); { Read beyond end!!! }
If (Handle = -1) Then Error(stReadError, 103); { File not open }
P := @Buf; { Transfer address }
Ri := 0; { Zero read index }
While (Count > 0) AND (Status = stOk) Do Begin { Check status & count }
W := Count; { Transfer read size }
If (Count > $FFFE) Then W := $FFFE; { Cant read >64K bytes }
Success := FileRead(Handle, P^[Ri], W, Moved); { Read from file }
If ((Success <> 0) OR (Moved <> W)) { Error was detected }
Then Begin
Moved := 0; { Clear bytes moved }
If (Success <> 0) Then
Error(stReadError, Success) { Specific read error }
Else Error(stReadError, 0); { Non specific error }
End;
Inc(Position, Moved); { Adjust position }
Inc(Ri, Moved); { Adjust read index }
Dec(Count, Moved); { Adjust count left }
End;
If (Count <> 0) Then FillChar(P^[Ri], Count, #0); { Error clear buffer }
END;
{--TDosStream---------------------------------------------------------------}
{ Write -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TDosStream.Write (Var Buf; Count: Word);
VAR Success: Integer; W, Wi: Word; Moved: Sw_Word; P: PByteArray;
BEGIN
If (Handle = -1) Then Error(stWriteError, 103); { File not open }
P := @Buf; { Transfer address }
Wi := 0; { Zero write index }
While (Count > 0) AND (Status = stOk) Do Begin { Check status & count }
W := Count; { Transfer read size }
If (Count > $FFFE) Then W := $FFFE; { Cant read >64K bytes }
Success := FileWrite(Handle, P^[Wi], W, Moved); { Write to file }
If ((Success <> 0) OR (Moved <> W)) { Error was detected }
Then Begin
Moved := 0; { Clear bytes moved }
If (Success <> 0) Then
Error(stWriteError, Success) { Specific write error }
Else Error(stWriteError, 0); { Non specific error }
End;
Inc(Position, Moved); { Adjust position }
Inc(Wi, Moved); { Adjust write index }
Dec(Count, Moved); { Adjust count left }
If (Position > StreamSize) Then { File expanded }
StreamSize := Position; { Adjust stream size }
End;
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TBufStream OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TBufStream---------------------------------------------------------------}
{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17May96 LdB }
{---------------------------------------------------------------------------}
CONSTRUCTOR TBufStream.Init (FileName: FNameStr; Mode, Size: Word);
BEGIN
Inherited Init(FileName, Mode); { Call ancestor }
If (Size <> 0) AND (MaxAvail >= Size) Then Begin
GetMem(Buffer, Size); { Allocate buffer }
BufSize := Size; { Hold buffer size }
End;
If (Buffer = Nil) Then Error(stInitError, 0); { Buffer allocate fail }
END;
{--TBufStream---------------------------------------------------------------}
{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17May96 LdB }
{---------------------------------------------------------------------------}
DESTRUCTOR TBufStream.Done;
BEGIN
Flush; { Flush the file }
Inherited Done; { Call ancestor }
If (Buffer <> Nil) Then FreeMem(Buffer, BufSize); { Release buffer }
END;
{--TBufStream---------------------------------------------------------------}
{ Close -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TBufStream.Close;
BEGIN
Flush; { Flush the buffer }
Inherited Close; { Call ancestor }
END;
{--TBufStream---------------------------------------------------------------}
{ Flush -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TBufStream.Flush;
VAR Success: Integer; W: Sw_Word;
BEGIN
If (LastMode = 2) AND (BufPtr <> 0) Then Begin { Must update file }
If (Handle = -1) Then Success := 103 { File is not open }
Else Success := FileWrite(Handle, Buffer^,
BufPtr, W); { Write to file }
If (Success <> 0) OR (W <> BufPtr) Then { We have an error }
If (Success = 0) Then Error(stWriteError, 0) { Unknown write error }
Else Error(stError, Success); { Specific write error }
End;
BufPtr := 0; { Reset buffer ptr }
BufEnd := 0; { Reset buffer end }
END;
{--TBufStream---------------------------------------------------------------}
{ Truncate -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TBufStream.Truncate;
BEGIN
Flush; { Flush buffer }
Inherited Truncate; { Truncate file }
END;
{--TBufStream---------------------------------------------------------------}
{ Seek -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TBufStream.Seek (Pos: LongInt);
BEGIN
If (Status = stOk) Then Begin { Check status okay }
If (Position <> Pos) Then Begin { Move required }
Flush; { Flush the buffer }
Inherited Seek(Pos); { Call ancestor }
End;
End;
END;
{--TBufStream---------------------------------------------------------------}
{ Open -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TBufStream.Open (OpenMode: Word);
BEGIN
If (Status = stOk) Then Begin { Check status okay }
BufPtr := 0; { Clear buffer start }
BufEnd := 0; { Clear buffer end }
Inherited Open(OpenMode); { Call ancestor }
End;
END;
{--TBufStream---------------------------------------------------------------}
{ Read -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TBufStream.Read (Var Buf; Count: Word);
VAR Success: Integer; W, Bw, Ri: Word; Br: Sw_Word; P: PByteArray;
BEGIN
If (Position + Count > StreamSize) Then { Read pas stream end }
Error(stReadError, 0); { Call stream error }
If (Handle = -1) Then Error(stReadError, 103); { File not open }
P := @Buf; { Transfer address }
Ri := 0; { Zero read index }
If (LastMode = 2) Then Flush; { Flush write buffer }
LastMode := 1; { Now set read mode }
While (Count > 0) AND (Status = stOk) Do Begin { Check status & count }
If (BufPtr = BufEnd) Then Begin { Buffer is empty }
If (Position + BufSize > StreamSize) Then
Bw := StreamSize - Position { Amount of file left }
Else Bw := BufSize; { Full buffer size }
Success := FileRead(Handle, Buffer^, Bw, Br); { Read from file }
If ((Success <> 0) OR (Bw <> Br)) Then Begin { Error was detected }
If (Success <> 0) Then
Error(stReadError, Success) { Specific read error }
Else Error(stReadError, 0); { Non specific error }
End Else Begin
BufPtr := 0; { Reset BufPtr }
BufEnd := Bw; { End of buffer }
End;
End;
If (Status = stOk) Then Begin { Status still okay }
W := BufEnd - BufPtr; { Space in buffer }
If (Count < W) Then W := Count; { Set transfer size }
Move(Buffer^[BufPtr], P^[Ri], W); { Data from buffer }
Dec(Count, W); { Reduce count }
Inc(BufPtr, W); { Advance buffer ptr }
Inc(Ri, W); { Increase read index }
Inc(Position, W); { Advance position }
End;
End;
If (Status <> stOk) AND (Count > 0) Then
FillChar(P^[Ri], Count, #0); { Error clear buffer }
END;
{--TBufStream---------------------------------------------------------------}
{ Write -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TBufStream.Write (Var Buf; Count: Word);
VAR Success: Integer; W, Wi: Word; Bw: Sw_Word; P: PByteArray;
BEGIN
If (Handle = -1) Then Error(stWriteError, 103); { File not open }
If (LastMode = 1) Then Flush; { Flush read buffer }
LastMode := 2; { Now set write mode }
P := @Buf; { Transfer address }
Wi := 0; { Zero write index }
While (Count > 0) AND (Status = stOk) Do Begin { Check status & count }
If (BufPtr = BufSize) Then Begin { Buffer is full }
Success := FileWrite(Handle, Buffer^, BufSize,
Bw); { Write to file }
If (Success <> 0) OR (Bw <> BufSize) Then { We have an error }
If (Success=0) Then Error(stWriteError, 0) { Unknown write error }
Else Error(stError, Success); { Specific write error }
BufPtr := 0; { Reset BufPtr }
End;
If (Status = stOk) Then Begin { Status still okay }
W := BufSize - BufPtr; { Space in buffer }
If (Count < W) Then W := Count; { Transfer size }
Move(P^[Wi], Buffer^[BufPtr], W); { Data to buffer }
Dec(Count, W); { Reduce count }
Inc(BufPtr, W); { Advance buffer ptr }
Inc(Wi, W); { Advance write index }
Inc(Position, W); { Advance position }
If (Position > StreamSize) Then { File has expanded }
StreamSize := Position; { Update new size }
End;
End;
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TMemoryStream OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TMemoryStream------------------------------------------------------------}
{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May96 LdB }
{---------------------------------------------------------------------------}
CONSTRUCTOR TMemoryStream.Init (ALimit: LongInt; ABlockSize: Word);
VAR W: Word;
BEGIN
Inherited Init; { Call ancestor }
If (ABlockSize = 0) Then BlkSize := 8192 Else { Default blocksize }
BlkSize := ABlockSize; { Set blocksize }
If (ALimit = 0) Then W := 1 Else { At least 1 block }
W := (ALimit + BlkSize - 1) DIV BlkSize; { Blocks needed }
If NOT ChangeListSize(W) Then { Try allocate blocks }
Error(stInitError, 0); { Initialize error }
END;
{--TMemoryStream------------------------------------------------------------}
{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May96 LdB }
{---------------------------------------------------------------------------}
DESTRUCTOR TMemoryStream.Done;
BEGIN
ChangeListSize(0); { Release all memory }
Inherited Done; { Call ancestor }
END;
{--TMemoryStream------------------------------------------------------------}
{ Truncate -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TMemoryStream.Truncate;
VAR W: Word;
BEGIN
If (Status = stOk) Then Begin { Check status okay }
If (Position = 0) Then W := 1 Else { At least one block }
W := (Position + BlkSize - 1) DIV BlkSize; { Blocks needed }
If ChangeListSize(W) Then StreamSize := Position { Set stream size }
Else Error(stError, 0); { Error truncating }
End;
END;
{--TMemoryStream------------------------------------------------------------}
{ Read -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TMemoryStream.Read (Var Buf; Count: Word);
VAR W, CurBlock, BlockPos, Op: Word; Li: LongInt; P, Q: PByteArray;
BEGIN
If (Position + Count > StreamSize) Then { Insufficient data }
Error(stReadError, 0); { Read beyond end!!! }
P := @Buf; { Transfer address }
Op := 0; { Zero offset position }
While (Count > 0) AND (Status = stOk) Do Begin { Check status & count }
CurBlock := Position DIV BlkSize; { Current block }
{ * REMARK * - Do not shorten this, result can be > 64K }
Li := CurBlock; { Transfer current block }
Li := Li * BlkSize; { Current position }
{ * REMARK END * - Leon de Boer }
BlockPos := Position - Li; { Current position }
W := BlkSize - BlockPos; { Current block space }
If (W > Count) Then W := Count; { Adjust read size }
Q := BlkList^[CurBlock]; { Calc pointer }
Move(Q^[BlockPos], P^[Op], W); { Move data to buffer }
Inc(Position, W); { Adjust position }
Inc(Op, W); { Increase offset }
Dec(Count, W); { Adjust count left }
End;
If (Count <> 0) Then FillChar(P^[Op], Count, #0); { Error clear buffer }
END;
{--TMemoryStream------------------------------------------------------------}
{ Write -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TMemoryStream.Write (Var Buf; Count: Word);
VAR W, CurBlock, BlockPos, Op: Word; Li: LongInt; P, Q: PByteArray;
BEGIN
If (Position + Count > MemSize) Then Begin { Expansion needed }
If (Position + Count = 0) Then W := 1 Else { At least 1 block }
W := (Position+Count+BlkSize-1) DIV BlkSize; { Blocks needed }
If NOT ChangeListSize(W) Then
Error(stWriteError, 0); { Expansion failed!!! }
End;
P := @Buf; { Transfer address }
Op := 0; { Zero offset position }
While (Count > 0) AND (Status = stOk) Do Begin { Check status & count }
CurBlock := Position DIV BlkSize; { Current segment }
{ * REMARK * - Do not shorten this, result can be > 64K }
Li := CurBlock; { Transfer current block }
Li := Li * BlkSize; { Current position }
{ * REMARK END * - Leon de Boer }
BlockPos := Position - Li; { Current position }
W := BlkSize - BlockPos; { Current block space }
If (W > Count) Then W := Count; { Adjust write size }
Q := BlkList^[CurBlock]; { Calc pointer }
Move(P^[Op], Q^[BlockPos], W); { Transfer data }
Inc(Position, W); { Adjust position }
Inc(Op, W); { Increase offset }
Dec(Count, W); { Adjust count left }
If (Position > StreamSize) Then { File expanded }
StreamSize := Position; { Adjust stream size }
End;
END;
{***************************************************************************}
{ TMemoryStream PRIVATE METHODS }
{***************************************************************************}
{--TMemoryStream------------------------------------------------------------}
{ ChangeListSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TMemoryStream.ChangeListSize (ALimit: Word): Boolean;
VAR I, W, Bas: Word; P: PPointerArray;
BEGIN
If (ALimit <> BlkCount) Then Begin { Change is needed }
ChangeListSize := False; { Preset failure }
If (ALimit > MaxPtrs) Then Exit; { To many blocks req }
If (ALimit <> 0) Then Begin { Create segment list }
Bas := ALimit * SizeOf(Pointer); { Block array size }
If (MaxAvail > Bas) Then Begin
GetMem(P, Bas); { Allocate memory }
FillChar(P^, Bas, #0); { Clear the memory }
End Else Exit; { Insufficient memory }
If (BlkCount <> 0) AND (BlkList <> Nil) Then { Current list valid }
If (BlkCount <= ALimit) Then Move(BlkList^,
P^, BlkCount * SizeOf(Pointer)) Else { Move whole old list }
Move(BlkList^, P^, Bas); { Move partial list }
End Else P := Nil; { No new block list }
If (ALimit < BlkCount) Then { Shrink stream size }
For W := BlkCount-1 DownTo ALimit Do
FreeMem(BlkList^[W], BlkSize); { Release memory block }
If (P <> Nil) AND (ALimit > BlkCount) Then Begin { Expand stream size }
For W := BlkCount To ALimit-1 Do Begin
If (MaxAvail < BlkSize) Then Begin { Check enough memory }
For I := BlkCount To W-1 Do
FreeMem(P^[I], BlkSize); { Free mem allocated }
FreeMem(P, Bas); { Release memory }
Exit; { Now exit }
End Else GetMem(P^[W], BlkSize); { Allocate memory }
End;
End;
If (BlkCount <> 0) AND (BlkList<>Nil) Then
FreeMem(BlkList, BlkCount * SizeOf(Pointer)); { Release old list }
BlkList := P; { Hold new block list }
BlkCount := ALimit; { Hold new count }
{ * REMARK * - Do not shorten this, result can be > 64K }
MemSize := BlkCount; { Block count }
MemSize := MemSize * BlkSize; { Current position }
{ * REMARK END * - Leon de Boer }
End;
ChangeListSize := True; { Successful }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TEmsStream OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TEmsStream---------------------------------------------------------------}
{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Feb97 LdB }
{---------------------------------------------------------------------------}
CONSTRUCTOR TEmsStream.Init (MinSize, MaxSize: LongInt);
{$IFDEF PROC_Real} { DOS REAL MODE CODE }
VAR Success: Integer; MinPg, MaxPg: Word;
BEGIN
Inherited Init; { Call ancestor }
If (EMS_MemAvail >= MaxSize) Then Begin { Sufficient memory }
If (MaxSize = 0) Then MaxPg := 1 Else { At least one page }
MaxPg := (MaxSize + 16383) DIV 16384; { Max pages needed }
If (MinSize = 0) Then MinPg := 1 Else { At least one page }
MinPg := (MinSize + 16383) DIV 16384; { Min pages needed }
Handle := EMS_GetMem(MaxPg); { Allocate EMS pages }
If (Handle <> 0) Then Begin
Success := 0; { Preset success }
PageCount := MaxPg; { Pages used }
If (MaxPg <> MinPg) Then { Sizes differ }
If (EMS_ResizeMem(MinPg, Handle)=0) { Resize to minimum }
Then PageCount := MinPg; { Hold new page count }
{ * REMARK * - Do not shorten this, result can be > 64K }
MemSize := PageCount;
MemSize := MemSize * 16384;
{ * REMARK END * - Leon de Boer }
End Else Success := 403; { Failed to allocate }
End Else Success := 400; { Insufficent EMS }
If (Handle = 0) OR (Success <> 0) Then { EMS failed }
Error(stInitError, Success); { Call stream error }
END;
{$ELSE} { ALL OTHER OS SYSTEMS }
BEGIN
Inherited Init(MaxSize, 16384); { For compatability }
END;
{$ENDIF}
{$IFDEF PROC_Real} { DOS REAL MODE CODE }
{***************************************************************************}
{ TEMSStream DOS REAL MODE ONLY METHODS }
{***************************************************************************}
{--TEmsStream---------------------------------------------------------------}
{ Done -> Platforms DOS REAL MODE - Updated 28Feb97 LdB }
{---------------------------------------------------------------------------}
DESTRUCTOR TEmsStream.Done;
BEGIN
If (Handle <> 0) Then EMS_FreeMem(Handle); { Release EMS blocks }
Inherited Done; { Call ancestor }
END;
{--TEmsStream---------------------------------------------------------------}
{ Truncate -> Platforms DOS REAL MODE - Updated 28Feb97 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TEmsStream.Truncate;
VAR Success: Integer; W: Word;
BEGIN
If (Status = stOk) Then Begin { Check status okay }
If (Position = 0) Then W := 1 Else { At least one page }
W := (Position + 16383) DIV 16384; { Pages to use }
Success := 0; { Preset success }
If (W <> PageCount) Then { Sizes differ }
If (EMS_ResizeMem(W, Handle)=0) Then { Resize to this }
PageCount := W Else Success := 401; { Adjust blocks used }
If (Success = 0) Then StreamSize := Position { Adjust size }
Else Error(stError, Success); { Identify error }
End;
END;
{--TEmsStream---------------------------------------------------------------}
{ Read -> Platforms DOS REAL MODE - Updated 27Oct99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TEmsStream.Read (Var Buf; Count: Word);
VAR Success: Integer; W, Ri: Word; P: PByteArray;
BEGIN
If (Position + Count > StreamSize) Then { Insufficient data }
Error(stReadError, 0); { Read beyond end!!! }
If (Handle = 0) Then Error(stReadError, 403); { EMS not available }
P := @Buf; { Transfer address }
Ri := 0; { Zero read index }
While (Count > 0) AND (Status = stOk) Do Begin { Check status & count }
W := Count; { Transfer read size }
If (Count > $FFFE) Then W := $FFFE; { Cant read >64K bytes }
Success := EMS_MoveMem(LongInt(P^[Ri]), 0,
Position, Handle, W); { Move the data }
If (Success <> 0) Then Begin { Error was detected }
W := 0; { Clear bytes moved }
Error(stReadError, Success) { Specific read error }
End;
Inc(Position, W); { Adjust position }
Inc(Ri, W); { Adjust read index }
Dec(Count, W); { Adjust count left }
End;
If (Count <> 0) Then FillChar(P^[Ri], Count, #0); { Error clear buffer }
END;
{--TEmsStream---------------------------------------------------------------}
{ Write -> Platforms DOS REAL MODE - Updated 27Oct99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TEmsStream.Write (Var Buf; Count: Word);
VAR Success: Integer; W, Wi: Word; P: PByteArray;
BEGIN
If (Position + Count > MemSize) Then Begin { Expansion needed }
If (Position + Count = 0) Then W := 1 Else { At least one page }
W := (Position+Count + 16383) DIV 16384; { Pages needed }
If (EMS_ResizeMem(W, Handle)=0) Then Begin { Resize memory }
PageCount := W; { Adjust page count }
{ * REMARK * - Do not shorten this, result can be > 64K }
MemSize := PageCount;
MemSize := MemSize * 1024; { New memory size }
{ * REMARK END * - Leon de Boer }
End Else Error(stWriteError, 0); { We have an error }
End;
If (Handle = 0) Then Error(stWriteError, 403); { EMS not available }
P := @Buf; { Transfer address }
Wi := 0; { Zero write index }
While (Count > 0) AND (Status = stOk) Do Begin { Check status & count }
W := Count; { Transfer read size }
If (Count > $FFFE) Then W := $FFFE; { Cant read >64K bytes }
Success := EMS_MoveMem(Position, Handle,
LongInt(P^[Wi]), 0, W); { Move the memory }
If (Success <> 0) Then Begin { Error was detected }
W := 0; { Clear bytes moved }
Error(stWriteError, Success); { Specific write error }
End;
Inc(Position, W); { Adjust position }
Inc(Wi, W); { Adjust write index }
Dec(Count, W); { Adjust count left }
If (Position > StreamSize) Then { File expanded }
StreamSize := Position; { Adjust stream size }
End;
END;
{$ENDIF}
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TXmsStream OBJECT ANCESTOR }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TXmsStream---------------------------------------------------------------}
{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Feb97 LdB }
{---------------------------------------------------------------------------}
CONSTRUCTOR TXmsStream.Init (MinSize, MaxSize: LongInt);
{$IFDEF PROC_Real} { DOS REAL MODE CODE }
VAR Success: Integer; MinBlk, MaxBlk: Word;
BEGIN
Inherited Init; { Call ancestor }
If (XMS_MemAvail >= MaxSize) Then Begin { Sufficient memory }
If (MaxSize = 0) Then MaxBlk := 1 Else { At least one block }
MaxBlk := (MaxSize + 1023) DIV 1024; { Max blocks needed }
If (MinSize = 0) Then MinBlk := 1 Else { At least one block }
MinBlk := (MinSize + 1023) DIV 1024; { Min blocks needed }
Handle := XMS_GetMem(MaxBlk); { Allocate XMS blocks }
If (Handle <> 0) Then Begin
Success := 0; { Preset success }
BlocksUsed := MaxBlk; { Blocks used }
If (MaxBlk <> MinBlk) Then { Sizes differ }
If (XMS_ResizeMem(MaxBlk, MinBlk, Handle)=0) { Resize to minimum }
Then BlocksUsed := MinBlk; { Hold block size }
{ * REMARK * - Do not shorten this, result can be > 64K }
MemSize := BlocksUsed;
MemSize := MemSize * 1024;
{ * REMARK END * - Leon de Boer }
End Else Success := 303; { Failed to allocate }
End Else Success := 300; { Insufficent XMS }
If (Handle = 0) OR (Success <> 0) Then { XMS failed }
Error(stInitError, Success); { Call stream error }
END;
{$ELSE} { ALL OTHER OP SYSTEMS }
BEGIN
Inherited Init(MaxSize, 16384); { For compatability }
END;
{$ENDIF}
{$IFDEF PROC_Real} { DOS REAL MODE CODE }
{***************************************************************************}
{ TXMSStream DOS REAL MODE ONLY METHODS }
{***************************************************************************}
{--TXmsStream---------------------------------------------------------------}
{ Done -> Platforms DOS REAL MODE - Updated 28Feb97 LdB }
{---------------------------------------------------------------------------}
DESTRUCTOR TXmsStream.Done;
BEGIN
If (Handle <> 0) Then XMS_FreeMem(Handle); { Release XMS blocks }
Inherited Done; { Call ancestor }
END;
{--TXmsStream---------------------------------------------------------------}
{ Truncate -> Platforms DOS REAL MODE - Updated 28Feb97 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TXmsStream.Truncate;
VAR Success: Integer; W: Word;
BEGIN
If (Status = stOk) Then Begin { Check status okay }
If (Position = 0) Then W := 1 Else { At least 1 block }
W := (Position + 1023) DIV 1024; { Blocks to use }
Success := 0; { Preset success }
If (W <> BlocksUsed) Then { Sizes differ }
If (XMS_ResizeMem(BlocksUsed, W, Handle)=0) { Resize to this }
Then Begin
BlocksUsed := W; { Adjust blocks used }
{ * REMARK * - Do not shorten this, result can be > 64K }
MemSize := BlocksUsed; { Blocks used }
MemSize := MemSize * 1024; { Mult by block size }
{ * REMARK END * - Leon de Boer }
End Else Success := 301; { Resize failed }
If (Success = 0) Then StreamSize := Position { Adjust size }
Else Error(stError, Success); { Identify error }
End;
END;
{--TXmsStream---------------------------------------------------------------}
{ Read -> Platforms DOS REAL MODE - Updated 27Oct99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TXmsStream.Read (Var Buf; Count: Word);
VAR Success: Integer; W, Ri: Word; P: PByteArray;
BEGIN
If (Position + Count > StreamSize) Then { Insufficient data }
Error(stReadError, 0); { Read beyond end!!! }
If (Handle = 0) Then Error(stReadError, 303); { XMS not available }
P := @Buf; { Transfer address }
Ri := 0; { Zero read index }
While (Count > 0) AND (Status = stOk) Do Begin { Check status & count }
W := Count; { Transfer read size }
If (Count > $FFFE) Then W := $FFFE; { Cant read >64K bytes }
Success := XMS_MoveMem(LongInt(P^[Ri]), 0,
Position, Handle, W); { Move the data }
If (Success <> 0) Then Begin { Error was detected }
W := 0; { Clear bytes moved }
Error(stReadError, Success) { Specific read error }
End;
Inc(Position, W); { Adjust position }
Inc(Ri, W); { Adjust read index }
Dec(Count, W); { Adjust count left }
End;
If (Count <> 0) Then FillChar(P^[Ri], Count, #0); { Error clear buffer }
END;
{--TXmsStream---------------------------------------------------------------}
{ Write -> Platforms DOS REAL MODE - Updated 27Oct99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TXmsStream.Write (Var Buf; Count: Sw_Word);
VAR Success: Integer; W, Wi: Word; P: PByteArray;
BEGIN
{ * REMARK * - Because XMS must move even bytes we expand if within }
{ one byte of allocated size so we can read/write the }
{ last byte with an even access using a dummy end byte. }
{ * REMARK * - Leon de Boer }
If (Position + Count > (MemSize-1)) Then Begin { Expansion needed }
If (Position + Count = 0) Then W := 1 Else Begin { At least one }
W := (Position + Count + 1023) DIV 1024; { Blocks needed }
If ((Position + Count) MOD 1024 = 0) Then
Inc(W); { Fix for even access }
End;
If (XMS_ResizeMem(BlocksUsed, W, Handle)=0) { Resize memory }
Then Begin
BlocksUsed := W; { Adjust block count }
{ * REMARK * - Do not shorten this, result can be > 64K }
MemSize := BlocksUsed;
MemSize := MemSize * 1024; { New memory size }
{ * REMARK END * - Leon de Boer }
End Else Error(stWriteError, 0); { We have an error }
End;
If (Handle = 0) Then Error(stWriteError, 303); { XMS not available }
P := @Buf; { Transfer address }
Wi := 0; { Zero write index }
While (Count > 0) AND (Status = stOk) Do Begin { Check status & count }
W := Count; { Transfer read size }
If (Count > $FFFE) Then W := $FFFE; { Cant read >64K bytes }
Success := XMS_MoveMem(Position, Handle,
LongInt(P^[Wi]), 0, W); { Move the memory }
If (Success <> 0) Then Begin { Error was detected }
W := 0; { Clear bytes moved }
Error(stWriteError, Success); { Specific write error }
End;
Inc(Position, W); { Adjust position }
Inc(Wi, W); { Adjust write index }
Dec(Count, W); { Adjust count left }
If (Position > StreamSize) Then { File expanded }
StreamSize := Position; { Adjust stream size }
End;
END;
{$ENDIF}
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TCollection OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TCollection--------------------------------------------------------------}
{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
CONSTRUCTOR TCollection.Init (ALimit, ADelta: Integer);
BEGIN
Inherited Init; { Call ancestor }
Delta := ADelta; { Set increment }
SetLimit(ALimit); { Set limit }
END;
{--TCollection--------------------------------------------------------------}
{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
CONSTRUCTOR TCollection.Load (Var S: TStream);
VAR C, I: Integer;
BEGIN
S.Read(Count, 2); { Read count }
S.Read(Limit, 2); { Read limit }
S.Read(Delta, 2); { Read delta }
Items := Nil; { Clear item pointer }
C := Count; { Hold count }
I := Limit; { Hold limit }
Count := 0; { Clear count }
Limit := 0; { Clear limit }
SetLimit(I); { Set requested limit }
Count := C; { Set count }
For I := 0 To C-1 Do AtPut(I, GetItem(S)); { Get each item }
END;
{--TCollection--------------------------------------------------------------}
{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
DESTRUCTOR TCollection.Done;
BEGIN
FreeAll; { Free all items }
SetLimit(0); { Release all memory }
END;
{--TCollection--------------------------------------------------------------}
{ At -> Platforms DOS/DPMI/WIN/NT/OS2 -Updated 22May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TCollection.At (Index: Integer): Pointer;
BEGIN
If (Index < 0) OR (Index >= Count) Then Begin { Invalid index }
Error(coIndexError, Index); { Call error }
At := Nil; { Return nil }
End Else At := Items^[Index]; { Return item }
END;
{--TCollection--------------------------------------------------------------}
{ IndexOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TCollection.IndexOf (Item: Pointer): Integer;
VAR I: Integer;
BEGIN
If (Count > 0) Then Begin { Count is positive }
For I := 0 To Count-1 Do { For each item }
If (Items^[I] = Item) Then Begin { Look for match }
IndexOf := I; { Return index }
Exit; { Now exit }
End;
End;
IndexOf := -1; { Return index }
END;
{--TCollection--------------------------------------------------------------}
{ GetItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TCollection.GetItem (Var S: TStream): Pointer;
BEGIN
GetItem := S.Get; { Item off stream }
END;
{--TCollection--------------------------------------------------------------}
{ LastThat -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jul99 LdB }
{---------------------------------------------------------------------------}
FUNCTION TCollection.LastThat (Test: Pointer): Pointer;
VAR I: Integer;
BEGIN
For I := Count DownTo 1 Do Begin { Down from last item }
{$IFDEF PPC_VIRTUAL} { VIRTUAL COMPILER }
If CallTestLocal(Test, Items^[I-1]) { Test each item }
{$ELSE} { OTHER COMPILERS }
If CallTestLocal(Test, PrevFramePtr, Items^[I-1]){ Test each item }
{$ENDIF}
Then Begin { Test each item }
LastThat := Items^[I-1]; { Return successful }
Exit; { Now exit }
End;
End;
LastThat := Nil; { None passed test }
END;
{--TCollection--------------------------------------------------------------}
{ FirstThat -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jul99 LdB }
{---------------------------------------------------------------------------}
FUNCTION TCollection.FirstThat (Test: Pointer): Pointer;
VAR I: Integer;
BEGIN
For I := 1 To Count Do Begin { Up from first item }
{$IFDEF PPC_VIRTUAL} { VIRTUAL COMPILER }
If CallTestLocal(Test, Items^[I-1]) { Test each item }
{$ELSE} { OTHER COMPILERS }
If CallTestLocal(Test, PrevFramePtr, Items^[I-1]){ Test each item }
{$ENDIF}
Then Begin { Test each item }
FirstThat := Items^[I-1]; { Return successful }
Exit; { Now exit }
End;
End;
FirstThat := Nil; { None passed test }
END;
{--TCollection--------------------------------------------------------------}
{ Pack -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.Pack;
VAR I, J: Integer;
BEGIN
I := 0; { Initialize dest }
J := 0; { Intialize test }
While (I < Count) AND (J < Limit) Do Begin { Check fully packed }
If (Items^[J] <> Nil) Then Begin { Found a valid item }
If (I <> J) Then Begin
Items^[I] := Items^[J]; { Transfer item }
Items^[J] := Nil; { Now clear old item }
End;
Inc(I); { One item packed }
End;
Inc(J); { Next item to test }
End;
If (I < Count) Then Count := I; { New packed count }
END;
{--TCollection--------------------------------------------------------------}
{ FreeAll -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.FreeAll;
VAR I: Integer;
BEGIN
For I := 0 To Count-1 Do FreeItem(At(I)); { Release each item }
Count := 0; { Clear item count }
END;
{--TCollection--------------------------------------------------------------}
{ DeleteAll -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.DeleteAll;
BEGIN
Count := 0; { Clear item count }
END;
{--TCollection--------------------------------------------------------------}
{ Free -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.Free (Item: Pointer);
BEGIN
Delete(Item); { Delete from list }
FreeItem(Item); { Free the item }
END;
{--TCollection--------------------------------------------------------------}
{ Insert -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.Insert (Item: Pointer);
BEGIN
AtInsert(Count, Item); { Insert item }
END;
{--TCollection--------------------------------------------------------------}
{ Delete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.Delete (Item: Pointer);
BEGIN
AtDelete(IndexOf(Item)); { Delete from list }
END;
{--TCollection--------------------------------------------------------------}
{ AtFree -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.AtFree (Index: Integer);
VAR Item: Pointer;
BEGIN
Item := At(Index); { Retreive item ptr }
AtDelete(Index); { Delete item }
FreeItem(Item); { Free the item }
END;
{--TCollection--------------------------------------------------------------}
{ FreeItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.FreeItem (Item: Pointer);
VAR P: PObject;
BEGIN
P := PObject(Item); { Convert pointer }
If (P <> Nil) Then Dispose(P, Done); { Dispose of object }
END;
{--TCollection--------------------------------------------------------------}
{ AtDelete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.AtDelete (Index: Integer);
BEGIN
If (Index >= 0) AND (Index < Count) Then Begin { Valid index }
Dec(Count); { One less item }
If (Count > Index) Then Move(Items^[Index+1],
Items^[Index], (Count-Index)*Sizeof(Pointer)); { Shuffle items down }
End Else Error(coIndexError, Index); { Index error }
END;
{--TCollection--------------------------------------------------------------}
{ ForEach -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jul99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.ForEach (Action: Pointer);
VAR I: Integer;
BEGIN
For I := 1 To Count Do { Up from first item }
{$IFDEF PPC_VIRTUAL} { VIRTUAL COMPILER }
CallTestLocal(Action, Items^[I-1]); { Call with each item }
{$ELSE} { OTHER COMPILERS }
CallTestLocal(Action, PrevFramePtr, Items^[I-1]); { Call with each item }
{$ENDIF}
END;
{--TCollection--------------------------------------------------------------}
{ SetLimit -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.SetLimit (ALimit: Integer);
VAR AItems: PItemList;
BEGIN
If (ALimit < Count) Then ALimit := Count; { Stop underflow }
If (ALimit > MaxCollectionSize) Then
ALimit := MaxCollectionSize; { Stop overflow }
{$IFNDEF PPC_SPEED} { NON SPEED COMPILERS }
If (MaxAvail < (ALimit*SizeOf(Pointer))) Then { Check enough memory }
ALimit := Limit; { Insufficient memory }
{$ENDIF}
If (ALimit <> Limit) Then Begin { Limits differ }
If (ALimit = 0) Then AItems := Nil Else Begin { Alimit=0 nil entry }
GetMem(AItems, ALimit * SizeOf(Pointer)); { Allocate memory }
If (AItems <> Nil) Then FillChar(AItems^,
ALimit * SizeOf(Pointer), #0); { Clear the memory }
End;
If (AItems <> Nil) OR (ALimit = 0) Then Begin { Check success }
If (AItems <> Nil) AND (Items <> Nil) Then { Check both valid }
Move(Items^, AItems^, Count*SizeOf(Pointer));{ Move existing items }
If (Limit <> 0) AND (Items <> Nil) Then { Check old allocation }
FreeMem(Items, Limit * SizeOf(Pointer)); { Release memory }
Items := AItems; { Update items }
Limit := ALimit; { Set limits }
End;
End;
END;
{--TCollection--------------------------------------------------------------}
{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.Error (Code, Info: Integer);
BEGIN
RunError(212 - Code); { Run error }
END;
{--TCollection--------------------------------------------------------------}
{ AtPut -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.AtPut (Index: Integer; Item: Pointer);
BEGIN
If (Index >= 0) AND (Index < Count) Then { Index valid }
Items^[Index] := Item { Put item in index }
Else Error(coIndexError, Index); { Index error }
END;
{--TCollection--------------------------------------------------------------}
{ AtInsert -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.AtInsert (Index: Integer; Item: Pointer);
VAR I: Integer;
BEGIN
If (Index >= 0) AND (Index <= Count) Then Begin { Valid index }
If (Count=Limit) Then SetLimit(Limit+Delta); { Expand size if able }
If (Limit>Count) Then Begin
If (Index < Count) Then Begin { Not last item }
For I := Count-1 DownTo Index Do { Start from back }
Items^[I+1] := Items^[I]; { Move each item }
End;
Items^[Index] := Item; { Put item in list }
Inc(Count); { Inc count }
End Else Error(coOverflow, Index); { Expand failed }
End Else Error(coIndexError, Index); { Index error }
END;
{--TCollection--------------------------------------------------------------}
{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.Store (Var S: TStream);
PROCEDURE DoPutItem (P: Pointer); {$IFNDEF FPC} FAR;{$ENDIF}
BEGIN
PutItem(S, P); { Put item on stream }
END;
BEGIN
S.Write(Count, 2); { Write count }
S.Write(Limit, 2); { Write limit }
S.Write(Delta, 2); { Write delta }
ForEach(@DoPutItem); { Each item to stream }
END;
{--TCollection--------------------------------------------------------------}
{ PutItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TCollection.PutItem (Var S: TStream; Item: Pointer);
BEGIN
S.Put(Item); { Put item on stream }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TSortedCollection OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TSortedCollection--------------------------------------------------------}
{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
CONSTRUCTOR TSortedCollection.Init (ALimit, ADelta: Integer);
BEGIN
Inherited Init(ALimit, ADelta); { Call ancestor }
Duplicates := False; { Clear flag }
END;
{--TSortedCollection--------------------------------------------------------}
{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
CONSTRUCTOR TSortedCollection.Load (Var S: TStream);
BEGIN
Inherited Load(S); { Call ancestor }
S.Read(Duplicates, 1); { Read duplicate flag }
END;
{--TSortedCollection--------------------------------------------------------}
{ KeyOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TSortedCollection.KeyOf (Item: Pointer): Pointer;
BEGIN
KeyOf := Item; { Return item as key }
END;
{--TSortedCollection--------------------------------------------------------}
{ IndexOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TSortedCollection.IndexOf (Item: Pointer): Integer;
VAR I, J: Integer;
BEGIN
J := -1; { Preset result }
If Search(KeyOf(Item), I) Then Begin { Search for item }
If Duplicates Then { Duplicates allowed }
While (I < Count) AND (Item <> Items^[I]) Do
Inc(I); { Count duplicates }
If (I < Count) Then J := I; { Index result }
End;
IndexOf := J; { Return result }
END;
{--TSortedCollection--------------------------------------------------------}
{ Compare -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TSortedCollection.Compare (Key1, Key2: Pointer): Integer;
BEGIN
Abstract; { Abstract method }
END;
{--TSortedCollection--------------------------------------------------------}
{ Search -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TSortedCollection.Search (Key: Pointer; Var Index: Integer): Boolean;
VAR L, H, I, C: Integer;
BEGIN
Search := False; { Preset failure }
L := 0; { Start count }
H := Count - 1; { End count }
While (L <= H) Do Begin
I := (L + H) SHR 1; { Mid point }
C := Compare(KeyOf(Items^[I]), Key); { Compare with key }
If (C < 0) Then L := I + 1 Else Begin { Item to left }
H := I - 1; { Item to right }
If C = 0 Then Begin { Item match found }
Search := True; { Result true }
If NOT Duplicates Then L := I; { Force kick out }
End;
End;
End;
Index := L; { Return result }
END;
{--TSortedCollection--------------------------------------------------------}
{ Insert -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TSortedCollection.Insert (Item: Pointer);
VAR I: Integer;
BEGIN
If NOT Search(KeyOf(Item), I) OR Duplicates Then { Item valid }
AtInsert(I, Item); { Insert the item }
END;
{--TSortedCollection--------------------------------------------------------}
{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TSortedCollection.Store (Var S: TStream);
BEGIN
TCollection.Store(S); { Call ancestor }
S.Write(Duplicates, 1); { Write duplicate flag }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TStringCollection OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TStringCollection--------------------------------------------------------}
{ GetItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TStringCollection.GetItem (Var S: TStream): Pointer;
BEGIN
GetItem := S.ReadStr; { Get new item }
END;
{--TStringCollection--------------------------------------------------------}
{ Compare -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 21Aug97 LdB }
{---------------------------------------------------------------------------}
FUNCTION TStringCollection.Compare (Key1, Key2: Pointer): Integer;
VAR I, J: Integer; P1, P2: PString;
BEGIN
P1 := PString(Key1); { String 1 pointer }
P2 := PString(Key2); { String 2 pointer }
If (Length(P1^)<Length(P2^)) Then J := Length(P1^)
Else J := Length(P2^); { Shortest length }
I := 1; { First character }
While (I<J) AND (P1^[I]=P2^[I]) Do Inc(I); { Scan till fail }
If (I=J) Then Begin { Possible match }
{ * REMARK * - Bug fix 21 August 1997 }
If (P1^[I]<P2^[I]) Then Compare := -1 Else { String1 < String2 }
If (P1^[I]>P2^[I]) Then Compare := 1 Else { String1 > String2 }
If (Length(P1^)>Length(P2^)) Then Compare := 1 { String1 > String2 }
Else If (Length(P1^)<Length(P2^)) Then { String1 < String2 }
Compare := -1 Else Compare := 0; { String1 = String2 }
{ * REMARK END * - Leon de Boer }
End Else If (P1^[I]<P2^[I]) Then Compare := -1 { String1 < String2 }
Else Compare := 1; { String1 > String2 }
END;
{--TStringCollection--------------------------------------------------------}
{ FreeItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStringCollection.FreeItem (Item: Pointer);
BEGIN
DisposeStr(Item); { Dispose item }
END;
{--TStringCollection--------------------------------------------------------}
{ PutItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStringCollection.PutItem (Var S: TStream; Item: Pointer);
BEGIN
S.WriteStr(Item); { Write string }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TStrCollection OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TStrCollection-----------------------------------------------------------}
{ Compare -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TStrCollection.Compare (Key1, Key2: Pointer): Integer;
VAR I, J: Integer; P1, P2: PByteArray;
BEGIN
P1 := PByteArray(Key1); { PChar 1 pointer }
P2 := PByteArray(Key2); { PChar 2 pointer }
I := 0; { Preset no size }
If (P1 <> Nil) Then While (P1^[I] <> 0) Do Inc(I); { PChar 1 length }
J := 0; { Preset no size }
If (P2 <> Nil) Then While (P2^[J] <> 0) Do Inc(J); { PChar 2 length }
If (I < J) Then J := I; { Shortest length }
I := 0; { First character }
While (I < J) AND (P1^[I] = P2^[I]) Do Inc(I); { Scan till fail }
If (P1^[I] = P2^[I]) Then Compare := 0 Else { Strings matched }
If (P1^[I] < P2^[I]) Then Compare := -1 Else { String1 < String2 }
Compare := 1; { String1 > String2 }
END;
{--TStrCollection-----------------------------------------------------------}
{ GetItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TStrCollection.GetItem (Var S: TStream): Pointer;
BEGIN
GetItem := S.StrRead; { Get string item }
END;
{--TStrCollection-----------------------------------------------------------}
{ FreeItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStrCollection.FreeItem (Item: Pointer);
VAR I: Integer; P: PByteArray;
BEGIN
If (Item <> Nil) Then Begin { Item is valid }
P := PByteArray(Item); { Create byte pointer }
I := 0; { Preset no size }
While (P^[I] <> 0) Do Inc(I); { Find PChar end }
FreeMem(Item, I+1); { Release memory }
End;
END;
{--TStrCollection-----------------------------------------------------------}
{ PutItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStrCollection.PutItem (Var S: TStream; Item: Pointer);
BEGIN
S.StrWrite(Item); { Write the string }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TUnSortedStrCollection OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TUnSortedCollection------------------------------------------------------}
{ Insert -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TUnSortedStrCollection.Insert (Item: Pointer);
BEGIN
AtInsert(Count, Item); { Insert - NO sorting }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TResourceItem RECORD }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
TYPE
TResourceItem = PACKED RECORD
Posn: LongInt; { Resource position }
Size: LongInt; { Resource size }
Key : String; { Resource key }
End;
PResourceItem = ^TResourceItem;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TResourceCollection OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TResourceCollection------------------------------------------------------}
{ KeyOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TResourceCollection.KeyOf (Item: Pointer): Pointer;
BEGIN
KeyOf := @PResourceItem(Item)^.Key; { Pointer to key }
END;
{--TResourceCollection------------------------------------------------------}
{ GetItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TResourceCollection.GetItem (Var S: TStream): Pointer;
VAR B: Byte; Pos, Size: LongInt; P: PResourceItem; Ts: String;
BEGIN
S.Read(Pos, 4); { Read position }
S.Read(Size, 4); { Read size }
S.Read(B, 1); { Read key length }
If (MaxAvail > (SizeOf(TResourceItem)-SizeOf(Ts)))
Then Begin
GetMem(P, B + (SizeOf(TResourceItem) -
SizeOf(Ts) + 1)); { Allocate min memory }
P^.Posn := Pos; { Xfer position }
P^.Size := Size; { Xfer size }
{$IFDEF PPC_DELPHI3} { DELPHI 3+ COMPILER }
SetLength(P^.Key, B); { Xfer string length }
{$ELSE} { OTHER COMPILERS }
P^.Key[0] := Chr(B); { Xfer string length }
{$ENDIF}
S.Read(P^.Key[1], B); { Xfer string data }
End Else P := Nil; { Insufficient memory }
GetItem := P; { Return pointer }
END;
{--TResourceCollection------------------------------------------------------}
{ FreeItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TResourceCollection.FreeItem (Item: Pointer);
VAR S: String;
BEGIN
If (Item <> Nil) Then FreeMem(Item,
SizeOf(TResourceItem) - SizeOf(S) +
Length(PResourceItem(Item)^.Key) + 1); { Release memory }
END;
{--TResourceCollection------------------------------------------------------}
{ PutItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24May96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TResourceCollection.PutItem (Var S: TStream; Item: Pointer);
VAR Ts: String;
BEGIN
If (Item <> Nil) Then S.Write(PResourceItem(Item)^,
SizeOf(TResourceItem) - SizeOf(Ts) +
Length(PResourceItem(Item)^.Key) + 1); { Write to stream }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ PRIVATE RESOURCE MANAGER CONSTANTS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
CONST
RStreamMagic: LongInt = $52504246; { 'FBPR' }
RStreamBackLink: LongInt = $4C424246; { 'FBBL' }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ PRIVATE RESOURCE MANAGER TYPES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
TYPE
{$IFDEF NewExeFormat} { New EXE format }
TExeHeader = PACKED RECORD
eHdrSize: Word;
eMinAbove: Word;
eMaxAbove: Word;
eInitSS: Word;
eInitSP: Word;
eCheckSum: Word;
eInitPC: Word;
eInitCS: Word;
eRelocOfs: Word;
eOvlyNum: Word;
eRelocTab: Word;
eSpace: Array[1..30] of Byte;
eNewHeader: Word;
END;
{$ENDIF}
THeader = PACKED RECORD
Signature: Word;
Case Integer Of
0: (
LastCount: Word;
PageCount: Word;
ReloCount: Word);
1: (
InfoType: Word;
InfoSize: Longint);
End;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TResourceFile OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TResourceFile------------------------------------------------------------}
{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18Jun96 LdB }
{---------------------------------------------------------------------------}
CONSTRUCTOR TResourceFile.Init(AStream: PStream);
VAR Found, Stop: Boolean; Header: THeader;
{$IFDEF NewExeFormat} ExeHeader: TExeHeader; {$ENDIF}
BEGIN
TObject.Init; { Initialize object }
Found := False; { Preset false }
If (AStream <> Nil) Then Begin
Stream := AStream; { Hold stream }
BasePos := Stream^.GetPos; { Get position }
Repeat
Stop := True; { Preset stop }
If (BasePos <= Stream^.GetSize-SizeOf(THeader))
Then Begin { Valid file header }
Stream^.Seek(BasePos); { Seek to position }
Stream^.Read(Header, SizeOf(THeader)); { Read header }
Case Header.Signature Of
{$IFDEF NewExeFormat} { New format file }
$5A4D: Begin
Stream^.Read(ExeHeader, SizeOf(TExeHeader));
BasePos := ExeHeader.eNewHeader; { Hold position }
Stop := False; { Clear stop flag }
End;
$454E: Begin
BasePos := Stream^.GetSize - 8; { Hold position }
Stop := False; { Clear stop flag }
End;
$4246: Begin
Stop := False; { Clear stop flag }
Case Header.Infotype Of
$5250: Begin { Found Resource }
Found := True; { Found flag is true }
Stop := True; { Set stop flag }
End;
$4C42: Dec(BasePos, Header.InfoSize-8);{ Found BackLink }
$4648: Dec(BasePos, SizeOf(THeader)*2);{ Found HelpFile }
Else Stop := True; { Set stop flag }
End;
End;
$424E: If Header.InfoType = $3230 { Found Debug Info }
Then Begin
Dec(BasePos, Header.InfoSize); { Adjust position }
Stop := False; { Clear stop flag }
End;
{$ELSE} { Old EXE format }
$5A4D: Begin
Inc(BasePos, LongInt(Header.PageCount)*512
- (-Header.LastCount AND 511)); { Calc position }
Stop := False; { Clear stop flag }
End;
$4246: If Header.InfoType = $5250 Then { Header was found }
Found := True Else Begin
Inc(BasePos, Header.InfoSize + 8); { Adjust position }
Stop := False; { Clear stop flag }
End;
{$ENDIF}
End;
End;
Until Stop; { Until flag is set }
End;
If Found Then Begin { Resource was found }
Stream^.Seek(BasePos + SizeOf(LongInt) * 2); { Seek to position }
Stream^.Read(IndexPos, SizeOf(LongInt)); { Read index position }
Stream^.Seek(BasePos + IndexPos); { Seek to resource }
Index.Load(Stream^); { Load resource }
End Else Begin
IndexPos := SizeOf(LongInt) * 3; { Set index position }
Index.Init(0, 8); { Set index }
End;
END;
{--TResourceFile------------------------------------------------------------}
{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18Jun96 LdB }
{---------------------------------------------------------------------------}
DESTRUCTOR TResourceFile.Done;
BEGIN
Flush; { Flush the file }
Index.Done; { Dispose of index }
If (Stream <> Nil) Then Dispose(Stream, Done); { Dispose of stream }
END;
{--TResourceFile------------------------------------------------------------}
{ Count -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18Jun96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TResourceFile.Count: Integer;
BEGIN
Count := Index.Count; { Return index count }
END;
{--TResourceFile------------------------------------------------------------}
{ KeyAt -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18Jun96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TResourceFile.KeyAt (I: Integer): String;
BEGIN
KeyAt := PResourceItem(Index.At(I))^.Key; { Return key }
END;
{--TResourceFile------------------------------------------------------------}
{ Get -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18Jun96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TResourceFile.Get (Key: String): PObject;
VAR I: Integer;
BEGIN
If (Stream = Nil) OR (NOT Index.Search(@Key, I)) { No match on key }
Then Get := Nil Else Begin
Stream^.Seek(BasePos +
PResourceItem(Index.At(I))^.Posn); { Seek to position }
Get := Stream^.Get; { Get item }
End;
END;
{--TResourceFile------------------------------------------------------------}
{ SwitchTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18Jun96 LdB }
{---------------------------------------------------------------------------}
FUNCTION TResourceFile.SwitchTo (AStream: PStream; Pack: Boolean): PStream;
VAR NewBasePos: LongInt;
PROCEDURE DoCopyResource (Item: PResourceItem); {$IFNDEF FPC} FAR; {$ENDIF}
BEGIN
Stream^.Seek(BasePos + Item^.Posn); { Move stream position }
Item^.Posn := AStream^.GetPos - NewBasePos; { Hold new position }
AStream^.CopyFrom(Stream^, Item^.Size); { Copy the item }
END;
BEGIN
SwitchTo := Stream; { Preset return }
If (AStream <> Nil) AND (Stream <> Nil) Then Begin { Both streams valid }
NewBasePos := AStream^.GetPos; { Get position }
If Pack Then Begin
AStream^.Seek(NewBasePos + SizeOf(LongInt)*3); { Seek to position }
Index.ForEach(@DoCopyResource); { Copy each resource }
IndexPos := AStream^.GetPos - NewBasePos; { Hold index position }
End Else Begin
Stream^.Seek(BasePos); { Seek to position }
AStream^.CopyFrom(Stream^, IndexPos); { Copy the resource }
End;
Stream := AStream; { Hold new stream }
BasePos := NewBasePos; { New base position }
Modified := True; { Set modified flag }
End;
END;
{--TResourceFile------------------------------------------------------------}
{ Flush -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18Jun96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TResourceFile.Flush;
VAR ResSize: LongInt; LinkSize: LongInt;
BEGIN
If (Modified) AND (Stream <> Nil) Then Begin { We have modification }
Stream^.Seek(BasePos + IndexPos); { Seek to position }
Index.Store(Stream^); { Store the item }
ResSize := Stream^.GetPos - BasePos; { Hold position }
LinkSize := ResSize + SizeOf(LongInt) * 2; { Hold link size }
Stream^.Write(RStreamBackLink, SizeOf(LongInt)); { Write link back }
Stream^.Write(LinkSize, SizeOf(LongInt)); { Write link size }
Stream^.Seek(BasePos); { Move stream position }
Stream^.Write(RStreamMagic, SizeOf(LongInt)); { Write number }
Stream^.Write(ResSize, SizeOf(LongInt)); { Write record size }
Stream^.Write(IndexPos, SizeOf(LongInt)); { Write index position }
Stream^.Flush; { Flush the stream }
End;
Modified := False; { Clear modified flag }
END;
{--TResourceFile------------------------------------------------------------}
{ Delete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18Jun96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TResourceFile.Delete (Key: String);
VAR I: Integer;
BEGIN
If Index.Search(@Key, I) Then Begin { Search for key }
Index.Free(Index.At(I)); { Delete from index }
Modified := True; { Set modified flag }
End;
END;
{--TResourceFile------------------------------------------------------------}
{ Put -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18Jun96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TResourceFile.Put (Item: PObject; Key: String);
VAR I: Integer; P: PResourceItem;
BEGIN
If (Stream = Nil) Then Exit; { Stream not valid }
If Index.Search(@Key, I) Then P := Index.At(I) { Search for item }
Else Begin
If (MaxAvail > SizeOf(TResourceItem)-SizeOf(Key)){ Check free memory }
Then Begin
GetMem(P, Length(Key) + (SizeOf(TResourceItem)
- SizeOf(Key) + 1)); { Allocate memory }
P^.Key := Key; { Store key }
Index.AtInsert(I, P); { Insert item }
End Else P := Nil; { Insufficient memory }
End;
If (P <> Nil) Then Begin { Allocate worked }
P^.Posn := IndexPos; { Set index position }
Stream^.Seek(BasePos + IndexPos); { Seek file position }
Stream^.Put(Item); { Put item on stream }
IndexPos := Stream^.GetPos - BasePos; { Hold index position }
P^.Size := IndexPos - P^.Posn; { Calc size }
Modified := True; { Set modified flag }
End;
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TStringList OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TStringList--------------------------------------------------------------}
{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun97 LdB }
{---------------------------------------------------------------------------}
CONSTRUCTOR TStringList.Load (Var S: TStream);
VAR Size: Word;
BEGIN
Stream := @S; { Hold stream pointer }
S.Read(Size, SizeOf(Word)); { Read size }
BasePos := S.GetPos; { Hold position }
S.Seek(BasePos + Size); { Seek to position }
S.Read(IndexSize, SizeOf(Integer)); { Read index size }
If (MaxAvail >= IndexSize * SizeOf(TStrIndexRec)) { Check free memory }
Then Begin
GetMem(Index, IndexSize * SizeOf(TStrIndexRec)); { Allocate memory }
S.Read(Index^, IndexSize * SizeOf(TStrIndexRec));{ Read indexes }
End Else IndexSize := 0; { Insufficient memory }
END;
{--TStringList--------------------------------------------------------------}
{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun97 LdB }
{---------------------------------------------------------------------------}
DESTRUCTOR TStringList.Done;
BEGIN
FreeMem(Index, IndexSize * SizeOf(TStrIndexRec)); { Release memory }
END;
{--TStringList--------------------------------------------------------------}
{ Get -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun97 LdB }
{---------------------------------------------------------------------------}
FUNCTION TStringList.Get (Key: Word): String;
VAR I: Word; S: String;
BEGIN
S := ''; { Preset empty string }
If (IndexSize > 0) Then Begin { We must have strings }
I := 0; { First entry }
While (I < IndexSize) AND (S = '') Do Begin
If ((Key - Index^[I].Key) < Index^[I].Count) { Diff less than count }
Then ReadStr(S, Index^[I].Offset,
Key-Index^[I].Key); { Read the string }
Inc(I); { Next entry }
End;
End;
Get := S; { Return empty string }
END;
{***************************************************************************}
{ TStringList PRIVATE METHODS }
{***************************************************************************}
{--TStringList--------------------------------------------------------------}
{ ReadStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun97 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStringList.ReadStr (Var S: String; Offset, Skip: Word);
VAR B: Byte;
BEGIN
Stream^.Seek(BasePos + Offset); { Seek to position }
Inc(Skip); { Adjust skip }
Repeat
Stream^.Read(B, 1); { Read string size }
{$IFDEF PPC_DELPHI3} { DELPHI 3+ COMPILER }
SetLength(S, B); { Xfer string length }
{$ELSE} { OTHER COMPILERS }
S[0] := Chr(B); { Xfer string size }
{$ENDIF}
Stream^.Read(S[1], B); { Read string data }
Dec(Skip); { One string read }
Until (Skip = 0);
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ TStrListMaker OBJECT METHODS }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{--TStrListMaker------------------------------------------------------------}
{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun97 LdB }
{---------------------------------------------------------------------------}
CONSTRUCTOR TStrListMaker.Init (AStrSize, AIndexSize: Word);
BEGIN
Inherited Init; { Call ancestor }
StrSize := AStrSize; { Hold size }
If (MaxAvail >= AStrSize) Then
GetMem(Strings, AStrSize); { Allocate memory }
If (MaxAvail >= AIndexSize * SizeOf(TStrIndexRec)) { Check free memory }
Then Begin
IndexSize := AIndexSize; { Hold index size }
GetMem(Index, AIndexSize * SizeOf(TStrIndexRec));{ Allocate memory }
End;
END;
{--TStrListMaker------------------------------------------------------------}
{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun97 LdB }
{---------------------------------------------------------------------------}
DESTRUCTOR TStrListMaker.Done;
BEGIN
FreeMem(Index, IndexSize * SizeOf(TStrIndexRec)); { Free index memory }
FreeMem(Strings, StrSize); { Free data memory }
END;
{--TStrListMaker------------------------------------------------------------}
{ Put -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun97 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStrListMaker.Put (Key: Word; S: String);
BEGIN
If (Cur.Count = 16) OR (Key <> Cur.Key + Cur.Count)
Then CloseCurrent; { Close current }
If (Cur.Count = 0) Then Begin
Cur.Key := Key; { Set key }
Cur.Offset := StrPos; { Set offset }
End;
Inc(Cur.Count); { Inc count }
Move(S, Strings^[StrPos], Length(S) + 1); { Move string data }
Inc(StrPos, Length(S) + 1); { Adjust position }
END;
{--TStrListMaker------------------------------------------------------------}
{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun97 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStrListMaker.Store (Var S: TStream);
BEGIN
CloseCurrent; { Close all current }
S.Write(StrPos, SizeOf(Word)); { Write position }
S.Write(Strings^, StrPos); { Write string data }
S.Write(IndexPos, SizeOf(Word)); { Write index position }
S.Write(Index^, IndexPos * SizeOf(TStrIndexRec)); { Write indexes }
END;
{***************************************************************************}
{ TStrListMaker PRIVATE METHODS }
{***************************************************************************}
{--TStrListMaker------------------------------------------------------------}
{ CloseCurrent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun97 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TStrListMaker.CloseCurrent;
BEGIN
If (Cur.Count <> 0) Then Begin
Index^[IndexPos] := Cur; { Hold index position }
Inc(IndexPos); { Next index }
Cur.Count := 0; { Adjust count }
End;
END;
{***************************************************************************}
{ INTERFACE ROUTINES }
{***************************************************************************}
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ STREAM INTERFACE ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ Abstract -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Jun96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE Abstract;
BEGIN
RunError(211); { Abstract error }
END;
{---------------------------------------------------------------------------}
{ RegisterObjects -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 02Sep97 LdB }
{---------------------------------------------------------------------------}
PROCEDURE RegisterObjects;
BEGIN
RegisterType(RCollection); { Register object }
RegisterType(RStringCollection); { Register object }
RegisterType(RStrCollection); { Register object }
END;
{---------------------------------------------------------------------------}
{ RegisterType -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 02Sep97 LdB }
{---------------------------------------------------------------------------}
PROCEDURE RegisterType (Var S: TStreamRec);
VAR P: PStreamRec;
BEGIN
P := StreamTypes; { Current reg list }
While (P <> Nil) AND (P^.ObjType <> S.ObjType)
Do P := P^.Next; { Find end of chain }
If (P = Nil) AND (S.ObjType <> 0) Then Begin { Valid end found }
S.Next := StreamTypes; { Chain the list }
StreamTypes := @S; { We are now first }
End Else RegisterError; { Register the error }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ GENERAL FUNCTION INTERFACE ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ LongMul -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Feb98 LdB }
{---------------------------------------------------------------------------}
FUNCTION LongMul (X, Y: Integer): LongInt;
BEGIN
LongMul := LongInt(X*Y); { Multiply integers }
END;
{---------------------------------------------------------------------------}
{ LongDiv -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Feb98 LdB }
{---------------------------------------------------------------------------}
FUNCTION LongDiv (X: LongInt; Y: Integer): Integer;
BEGIN
LongDiv := Integer(X DIV Y); { Divid longint }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ DYNAMIC STRING INTERFACE ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ NewStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Jun96 LdB }
{---------------------------------------------------------------------------}
FUNCTION NewStr (S: String): PString;
VAR P: PString;
BEGIN
If (S = '') Then P := Nil Else Begin { Empty returns nil }
If (MaxAvail > Length(S)) Then Begin { Check free memory }
GetMem(P, Length(S) + 1); { Allocate memory }
If (P <> Nil) Then P^ := S; { Transfer string }
End Else P := Nil; { Insufficient memory }
End;
NewStr := P; { Return result }
END;
{---------------------------------------------------------------------------}
{ DisposeStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Jun96 LdB }
{---------------------------------------------------------------------------}
PROCEDURE DisposeStr (P: PString);
BEGIN
If (P <> Nil) Then FreeMem(P, Length(P^) + 1); { Release memory }
END;
END.
Reference in New Issue View Git Blame Copy Permalink