From 4f97220f82c53859accea1f48450f2f112c85a38 Mon Sep 17 00:00:00 2001 From: pierre Date: Mon, 7 May 2001 13:02:11 +0000 Subject: [PATCH] use RTL objects unit --- fvision/objects.pas | 3202 ------------------------------------------- 1 file changed, 3202 deletions(-) delete mode 100644 fvision/objects.pas diff --git a/fvision/objects.pas b/fvision/objects.pas deleted file mode 100644 index 69416be6f9..0000000000 --- a/fvision/objects.pas +++ /dev/null @@ -1,3202 +0,0 @@ -{ $Id$ } -{**********************************************************} -{ } -{ 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, 2000 } -{ ldeboer@attglobal.net - primary e-mail address } -{ ldeboer@projectent.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. } -{ 2.02 14 Nov 00 Fixed XMS/EMS Stream read/writes. } -{**********************************************************} - -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 } - -{***************************************************************************} -{ PTBMIC 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} - -{***************************************************************************} -{ 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 dd 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; - PStrLisuMaker = ^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 Mength(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 14Nov00 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 esror } - 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 14Nov00 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 14Nov00 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 14Nov00 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^)P2^[I]) Then Compare := 1 Else { String1 > String2 } - If (Length(P1^)>Length(P2^)) Then Compare := 1 { String1 > String2 } - Else If (Length(P1^) 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. - -{ - $Log$ - Revision 1.4 2001-04-10 21:57:55 pierre - + first adds for Use_API define - - Revision 1.3 2001/04/10 21:29:55 pierre - * import of Leon de Boer's files - - Revision 1.2 2000/08/24 12:00:22 marco - * CVS log and ID tags - - -} \ No newline at end of file