/rtl/inc/objects.pp
Puppet | 1453 lines | 1373 code | 80 blank | 0 comment | 6 complexity | 248e0293cffc453cd564ac2569da7ce2 MD5 | raw file
Possible License(s): GPL-2.0, LGPL-2.0, LGPL-2.1, LGPL-3.0, BSD-3-Clause
- {
- This file is part of the Free Pascal run time library.
- Copyright (c) 1999-2000 by the Free Pascal development team.
- Objects.pas clone for Free Pascal
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- **********************************************************************}
- {************[ SOURCE FILE OF FREE VISION ]****************}
- { }
- { System independent clone of objects.pas }
- { }
- { Interface Copyright (c) 1992 Borland International }
- { }
- { Parts Copyright (c) 1999-2000 by Florian Klaempfl }
- { fnklaemp@cip.ft.uni-erlangen.de }
- { }
- { Parts Copyright (c) 1999-2000 by Frank ZAGO }
- { zago@ecoledoc.ipc.fr }
- { }
- { Parts Copyright (c) 1999-2000 by MH Spiegel }
- { }
- { Parts Copyright (c) 1996, 1999-2000 by Leon de Boer }
- { ldeboer@ibm.net }
- { }
- { Free Vision project coordinator Balazs Scheidler }
- { bazsi@tas.vein.hu }
- { }
- UNIT Objects;
- {<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
- INTERFACE
- {<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
- {==== Select assembler ==============================================}
- {$IFDEF CPU86}
- {$ASMMODE ATT}
- {$ENDIF}
- {==== Compiler directives ===========================================}
- {$H-} { No ansistrings }
- {$X+} { Extended syntax is ok }
- {$R-} { Disable range checking }
- {$ifndef Unix}
- {$S-} { Disable Stack Checking }
- {$endif}
- {$I-} { Disable IO Checking }
- {$Q-} { Disable Overflow Checking }
- {$V-} { Turn off strict VAR strings }
- {$INLINE ON} {Turn on inlining.}
- {====================================================================}
- {$ifdef win32}
- uses
- Windows;
- {$endif}
- {***************************************************************************}
- { 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 = $3C00; { Create new file }
- stOpenRead = $3D00; { Read access only }
- stOpenWrite = $3D01; { Write access only }
- stOpen = $3D02; { 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 }
- {---------------------------------------------------------------------------}
- CONST
- vmtHeaderSize = 8; { VMT header size }
- CONST
- {---------------------------------------------------------------------------}
- { MAXIUM DATA SIZES }
- {---------------------------------------------------------------------------}
- {$IFDEF FPC}
- MaxBytes = 128*1024*128; { Maximum data size }
- {$ELSE}
- MaxBytes = 16384;
- {$ENDIF}
- MaxWords = MaxBytes DIV SizeOf(Word); { Max word data size }
- MaxPtrs = MaxBytes DIV SizeOf(Pointer); { Max ptr data size }
- MaxCollectionSize = MaxBytes DIV SizeOf(Pointer); { Max collection size }
- MaxTPCompatibleCollectionSize = 65520 div 4;
- {***************************************************************************}
- { PUBLIC TYPE DEFINITIONS }
- {***************************************************************************}
- {---------------------------------------------------------------------------}
- { CHARACTER SET }
- {---------------------------------------------------------------------------}
- TYPE
- TCharSet = SET Of Char; { Character set }
- PCharSet = ^TCharSet; { Character set ptr }
- {---------------------------------------------------------------------------}
- { GENERAL ARRAYS }
- {---------------------------------------------------------------------------}
- TYPE
- TByteArray = ARRAY [0..MaxBytes-1] Of Byte; { Byte array }
- PByteArray = ^TByteArray; { Byte array pointer }
- TWordArray = ARRAY [0..MaxWords-1] Of Word; { Word array }
- PWordArray = ^TWordArray; { Word array pointer }
- TPointerArray = Array [0..MaxPtrs-1] Of Pointer; { Pointer array }
- PPointerArray = ^TPointerArray; { Pointer array ptr }
- {---------------------------------------------------------------------------}
- { POINTER TO STRING }
- {---------------------------------------------------------------------------}
- TYPE
- PString = PShortString; { String pointer }
- {---------------------------------------------------------------------------}
- { OS dependent File type / consts }
- {---------------------------------------------------------------------------}
- type
- FNameStr = String;
- const
- MaxReadBytes = $7fffffff;
- var
- invalidhandle : THandle;
- {---------------------------------------------------------------------------}
- { DOS ASCIIZ FILENAME }
- {---------------------------------------------------------------------------}
- TYPE
- AsciiZ = Array [0..255] Of Char; { Filename array }
- {---------------------------------------------------------------------------}
- { BIT SWITCHED TYPE CONSTANTS }
- {---------------------------------------------------------------------------}
- TYPE
- Sw_Word = Cardinal; { Long Word now }
- Sw_Integer = LongInt; { Long integer now }
- {***************************************************************************}
- { PUBLIC RECORD DEFINITIONS }
- {***************************************************************************}
- {---------------------------------------------------------------------------}
- { TYPE CONVERSION RECORDS }
- {---------------------------------------------------------------------------}
- TYPE
- WordRec = packed RECORD
- {$ifdef ENDIAN_LITTLE}
- Lo, Hi: Byte; { Word to bytes }
- {$else}
- Hi,Lo: Byte;
- {$endif}
- END;
- LongRec = packed RECORD
- {$ifdef ENDIAN_LITTLE}
- Lo, Hi: Word; { LongInt to words }
- {$else}
- Hi,Lo: Word; { LongInt to words }
- {$endif}
- 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: Sw_Word; { Object type id }
- VmtLink: pointer; { VMT link }
- Load : Pointer; { Object load code }
- Store: Pointer; { Object store code }
- Next : PStreamRec; { Next stream record }
- END;
- {***************************************************************************}
- { PUBLIC OBJECT DEFINITIONS }
- {***************************************************************************}
- {---------------------------------------------------------------------------}
- { TPoint OBJECT - POINT OBJECT }
- {---------------------------------------------------------------------------}
- TYPE
- PPoint = ^TPoint;
- TPoint = OBJECT
- X, Y: Sw_Integer;
- END;
- {---------------------------------------------------------------------------}
- { TRect OBJECT - RECTANGLE OBJECT }
- {---------------------------------------------------------------------------}
- PRect = ^TRect;
- 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: Sw_Integer);
- PROCEDURE Grow (ADX, ADY: Sw_Integer);
- PROCEDURE Assign (XA, YA, XB, YB: Sw_Integer);
- END;
- {---------------------------------------------------------------------------}
- { TObject OBJECT - BASE ANCESTOR OBJECT }
- {---------------------------------------------------------------------------}
- TYPE
- TObject = OBJECT
- CONSTRUCTOR Init;
- PROCEDURE Free;
- FUNCTION Is_Object(P:Pointer):Boolean;
- 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 }
- TPCompatible : Boolean;
- CONSTRUCTOR Init;
- 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: LongInt); Virtual;
- PROCEDURE Write (Var Buf; Count: LongInt); 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: Longint); Virtual;
- PROCEDURE Write (Var Buf; Count: Longint); Virtual;
- private
- FileInfo : File;
- 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 : Longint; { Buffer size }
- BufPtr : Longint; { Buffer start }
- BufEnd : Longint; { 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: Longint); Virtual;
- PROCEDURE Write (Var Buf; Count: Longint); Virtual;
- END;
- PBufStream = ^TBufStream;
- { ******************************* REMARK ****************************** }
- { All the changes here should be completely transparent to existing }
- { code. Basically the memory blocks do not have to be base segments }
- { but this means our list becomes memory blocks rather than segments. }
- { The stream will also expand like the other standard streams!! }
- { ****************************** END REMARK *** Leon de Boer, 19May96 * }
- {---------------------------------------------------------------------------}
- { TMemoryStream OBJECT - MEMORY STREAM OBJECT }
- {---------------------------------------------------------------------------}
- TYPE
- TMemoryStream = OBJECT (TStream)
- BlkCount: Longint; { 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: Longint); Virtual;
- PROCEDURE Write (Var Buf; Count: Longint); Virtual;
- PRIVATE
- FUNCTION ChangeListSize (ALimit: Longint): Boolean;
- END;
- PMemoryStream = ^TMemoryStream;
- 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: Sw_Integer; { Item count }
- Limit: Sw_Integer; { Item limit count }
- Delta: Sw_Integer; { Inc delta size }
- CONSTRUCTOR Init (ALimit, ADelta: Sw_Integer);
- CONSTRUCTOR Load (Var S: TStream);
- DESTRUCTOR Done; Virtual;
- FUNCTION At (Index: Sw_Integer): Pointer;
- FUNCTION IndexOf (Item: Pointer): Sw_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: Sw_Integer);
- PROCEDURE FreeItem (Item: Pointer); Virtual;
- PROCEDURE AtDelete (Index: Sw_Integer);
- PROCEDURE ForEach (Action: Pointer);
- PROCEDURE SetLimit (ALimit: Sw_Integer); Virtual;
- PROCEDURE Error (Code, Info: Integer); Virtual;
- PROCEDURE AtPut (Index: Sw_Integer; Item: Pointer);
- PROCEDURE AtInsert (Index: Sw_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: Sw_Integer);
- CONSTRUCTOR Load (Var S: TStream);
- FUNCTION KeyOf (Item: Pointer): Pointer; Virtual;
- FUNCTION IndexOf (Item: Pointer): Sw_Integer; Virtual;
- FUNCTION Compare (Key1, Key2: Pointer): Sw_Integer; Virtual;
- FUNCTION Search (Key: Pointer; Var Index: Sw_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): Sw_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): Sw_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: Sw_Integer;
- FUNCTION KeyAt (I: Sw_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 : Sw_word;
- 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: Sw_Word): String;
- PRIVATE
- Stream : PStream;
- BasePos : Longint;
- IndexSize: Longint;
- Index : PStrIndex;
- PROCEDURE ReadStr (Var S: String; Offset, Skip: Longint);
- END;
- PStringList = ^TStringList;
- {---------------------------------------------------------------------------}
- { TStrListMaker OBJECT - RESOURCE FILE OBJECT }
- {---------------------------------------------------------------------------}
- TYPE
- TStrListMaker = OBJECT (TObject)
- CONSTRUCTOR Init (AStrSize, AIndexSize: Sw_Word);
- DESTRUCTOR Done; Virtual;
- PROCEDURE Put (Key: Sw_Word; S: String);
- PROCEDURE Store (Var S: TStream);
- PRIVATE
- StrPos : Sw_Word;
- StrSize : Sw_Word;
- Strings : PByteArray;
- IndexPos : Sw_Word;
- IndexSize: Sw_Word;
- Index : PStrIndex;
- Cur : TStrIndexRec;
- PROCEDURE CloseCurrent;
- END;
- PStrListMaker = ^TStrListMaker;
- {***************************************************************************}
- { INTERFACE ROUTINES }
- {***************************************************************************}
- {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
- { CALL HELPERS INTERFACE ROUTINES }
- {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
- { Constructor calls.
- Ctor Pointer to the constructor.
- Obj Pointer to the instance. NIL if new instance to be allocated.
- VMT Pointer to the VMT (obtained by TypeOf()).
- returns Pointer to the instance.
- }
- function CallVoidConstructor(Ctor: pointer; Obj: pointer; VMT: pointer): pointer;inline;
- function CallPointerConstructor(Ctor: pointer; Obj: pointer; VMT: pointer; Param1: pointer): pointer;inline;
- { Method calls.
- Method Pointer to the method.
- Obj Pointer to the instance. NIL if new instance to be allocated.
- returns Pointer to the instance.
- }
- function CallVoidMethod(Method: pointer; Obj: pointer): pointer;inline;
- function CallPointerMethod(Method: pointer; Obj: pointer; Param1: pointer): pointer;inline;
- { Local-function/procedure calls.
- Func Pointer to the local function (which must be far-coded).
- Frame Frame pointer of the wrapping function.
- }
- function CallVoidLocal(Func: pointer; Frame: Pointer): pointer;inline;
- function CallPointerLocal(Func: pointer; Frame: Pointer; Param1: pointer): pointer;inline;
- { Calls of functions/procedures local to methods.
- Func Pointer to the local function (which must be far-coded).
- Frame Frame pointer of the wrapping method.
- Obj Pointer to the object that the method belongs to.
- }
- function CallVoidMethodLocal(Func: pointer; Frame: Pointer; Obj: pointer): pointer;inline;
- function CallPointerMethodLocal(Func: pointer; Frame: Pointer; Obj: pointer; Param1: pointer): pointer;inline;
- {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
- { DYNAMIC STRING INTERFACE ROUTINES }
- {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
- {-NewStr-------------------------------------------------------------
- Allocates a dynamic string into memory. If S is nil, NewStr returns
- a nil pointer, otherwise NewStr allocates Length(S)+1 bytes of memory
- containing a copy of S, and returns a pointer to the string.
- 12Jun96 LdB
- ---------------------------------------------------------------------}
- FUNCTION NewStr (Const S: String): PString;
- {-DisposeStr---------------------------------------------------------
- Disposes of a PString allocated by the function NewStr.
- 12Jun96 LdB
- ---------------------------------------------------------------------}
- PROCEDURE DisposeStr (P: PString);
- PROCEDURE SetStr(VAR p:pString; CONST s:STRING);
- {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
- { 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.
- 04Sep97 LdB
- ---------------------------------------------------------------------}
- FUNCTION LongMul (X, Y: Integer): LongInt;
- {-LongDiv------------------------------------------------------------
- Returns the integer value of long integer X divided by integer Y.
- 04Sep97 LdB
- ---------------------------------------------------------------------}
- FUNCTION LongDiv (X: Longint; Y: Integer): Integer;
- {***************************************************************************}
- { PUBLIC INITIALIZED VARIABLES }
- {***************************************************************************}
- CONST
- {---------------------------------------------------------------------------}
- { INITIALIZED DOS/DPMI/WIN/OS2 PUBLIC VARIABLES }
- {---------------------------------------------------------------------------}
- StreamError: Pointer = Nil; { Stream error ptr }
- DefaultTPCompatible: Boolean = false;
- {---------------------------------------------------------------------------}
- { STREAM REGISTRATION RECORDS }
- {---------------------------------------------------------------------------}
- CONST
- RCollection: TStreamRec = (
- ObjType: 50;
- VmtLink: Ofs(TypeOf(TCollection)^);
- Load: @TCollection.Load;
- Store: @TCollection.Store;
- Next: Nil);
- RStringCollection: TStreamRec = (
- ObjType: 51;
- VmtLink: Ofs(TypeOf(TStringCollection)^);
- Load: @TStringCollection.Load;
- Store: @TStringCollection.Store;
- Next: Nil);
- RStrCollection: TStreamRec = (
- ObjType: 69;
- VmtLink: Ofs(TypeOf(TStrCollection)^);
- Load: @TStrCollection.Load;
- Store: @TStrCollection.Store;
- Next: Nil);
- RStringList: TStreamRec = (
- ObjType: 52;
- VmtLink: Ofs(TypeOf(TStringList)^);
- Load: @TStringList.Load;
- Store: Nil;
- Next: Nil);
- RStrListMaker: TStreamRec = (
- ObjType: 52;
- VmtLink: Ofs(TypeOf(TStrListMaker)^);
- Load: Nil;
- Store: @TStrListMaker.Store;
- Next: Nil);
- {<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
- IMPLEMENTATION
- {<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
- Uses dos;
- {***************************************************************************}
- { HELPER ROUTINES FOR CALLING }
- {***************************************************************************}
- type
- VoidLocal = function(_EBP: Pointer): pointer;
- PointerLocal = function(_EBP: Pointer; Param1: pointer): pointer;
- VoidMethodLocal = function(_EBP: Pointer): pointer;
- PointerMethodLocal = function(_EBP: Pointer; Param1: pointer): pointer;
- VoidConstructor = function(VMT: pointer; Obj: pointer): pointer;
- PointerConstructor = function(VMT: pointer; Obj: pointer; Param1: pointer): pointer;
- VoidMethod = function(Obj: pointer): pointer;
- PointerMethod = function(Obj: pointer; Param1: pointer): pointer;
- function CallVoidConstructor(Ctor: pointer; Obj: pointer; VMT: pointer): pointer;inline;
- begin
- CallVoidConstructor := VoidConstructor(Ctor)(Obj, VMT);
- end;
- function CallPointerConstructor(Ctor: pointer; Obj: pointer; VMT: pointer; Param1: pointer): pointer;inline;
- {$undef FPC_CallPointerConstructor_Implemented}
- begin
- {$define FPC_CallPointerConstructor_Implemented}
- CallPointerConstructor := PointerConstructor(Ctor)(Obj, VMT, Param1)
- end;
- {$ifndef FPC_CallPointerConstructor_Implemented}
- {$error CallPointerConstructor function not implemented}
- {$endif not FPC_CallPointerConstructor_Implemented}
- function CallVoidMethod(Method: pointer; Obj: pointer): pointer;inline;
- begin
- CallVoidMethod := VoidMethod(Method)(Obj)
- end;
- function CallPointerMethod(Method: pointer; Obj: pointer; Param1: pointer): pointer;inline;
- {$undef FPC_CallPointerMethod_Implemented}
- begin
- {$define FPC_CallPointerMethod_Implemented}
- CallPointerMethod := PointerMethod(Method)(Obj, Param1)
- end;
- {$ifndef FPC_CallPointerMethod_Implemented}
- {$error CallPointerMethod function not implemented}
- {$endif not FPC_CallPointerMethod_Implemented}
- function CallVoidLocal(Func: pointer; Frame: Pointer): pointer;inline;
- begin
- CallVoidLocal := VoidLocal(Func)(Frame)
- end;
- function CallPointerLocal(Func: pointer; Frame: Pointer; Param1: pointer): pointer;inline;
- begin
- CallPointerLocal := PointerLocal(Func)(Frame, Param1)
- end;
- function CallVoidMethodLocal(Func: pointer; Frame: Pointer; Obj: pointer): pointer;inline;
- begin
- CallVoidMethodLocal := VoidMethodLocal(Func)(Frame)
- end;
- function CallPointerMethodLocal(Func: pointer; Frame: Pointer; Obj: pointer; Param1: pointer): pointer;inline;
- begin
- CallPointerMethodLocal := PointerMethodLocal(Func)(Frame, Param1)
- end;
- {***************************************************************************}
- { PRIVATE INITIALIZED VARIABLES }
- {***************************************************************************}
- {---------------------------------------------------------------------------}
- { INITIALIZED DOS/DPMI/WIN/OS2 PRIVATE VARIABLES }
- {---------------------------------------------------------------------------}
- CONST
- StreamTypes: PStreamRec = Nil; { Stream types reg }
- {***************************************************************************}
- { PRIVATE INTERNAL ROUTINES }
- {***************************************************************************}
- {---------------------------------------------------------------------------}
- { RegisterError -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 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/OS2 - Checked 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/OS2 - Checked 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/OS2 - Checked 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/OS2 - Checked 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/OS2 - Checked 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/OS2 - Checked 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/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TRect.Move (ADX, ADY: Sw_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/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TRect.Grow (ADX, ADY: Sw_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/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TRect.Assign (XA, YA, XB, YB: Sw_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/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- CONSTRUCTOR TObject.Init;
- VAR LinkSize: LongInt; Dummy: DummyObject;
- BEGIN
- LinkSize := Pbyte(@Dummy.Data)-Pbyte(@Dummy); { Calc VMT link size }
- FillChar((Pbyte(@Self)+LinkSize)^,
- SizeOf(Self)-LinkSize, #0); { Clear data fields }
- END;
- {--TObject------------------------------------------------------------------}
- { Free -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TObject.Free;
- BEGIN
- Dispose(PObject(@Self), Done); { Dispose of self }
- END;
- {--TObject------------------------------------------------------------------}
- { Is_Object -> Platforms DOS/DPMI/WIN/OS2 - Checked 5Mar00 DM }
- {---------------------------------------------------------------------------}
- FUNCTION TObject.Is_Object(P:Pointer):Boolean;
- TYPE
- PVMT=^VMT;
- PPVMT=^PVMT;
- VMT=RECORD
- Size,NegSize:Longint;
- ParentLink:PVMT;
- END;
- VAR SP:PPVMT; Q:PVMT;
- BEGIN
- SP:=PPVMT(@SELF);
- Q:=SP^;
- Is_Object:=False;
- While Q<>Nil Do Begin
- IF Q=P THEN Begin
- Is_Object:=True;
- Break;
- End;
- Q:=Q^.Parentlink;
- End;
- END;
- {--TObject------------------------------------------------------------------}
- { Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- DESTRUCTOR TObject.Done;
- BEGIN { Abstract method }
- END;
- {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
- { TStream OBJECT METHODS }
- {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
- CONSTRUCTOR TStream.Init;
- BEGIN
- Status := StOK;
- ErrorInfo := 0;
- StreamSize := 0;
- Position := 0;
- TPCompatible := DefaultTPCompatible;
- END;
- {--TStream------------------------------------------------------------------}
- { Get -> Platforms DOS/DPMI/WIN/OS2 - Checked 02Sep97 LdB }
- {---------------------------------------------------------------------------}
- FUNCTION TStream.Get: PObject;
- VAR ObjType: Sw_Word; P: PStreamRec; ObjTypeWord: Word;
- BEGIN
- If TPCompatible Then Begin
- { Read 16-bit word for TP compatibility. }
- Read(ObjTypeWord, SizeOf(ObjTypeWord));
- ObjType := ObjTypeWord
- End
- else
- Read(ObjType, SizeOf(ObjType)); { 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
- Get :=PObject(
- CallPointerConstructor(P^.Load,Nil,P^.VMTLink, @Self)) { Call constructor }
- End Else Get := Nil; { Return nil pointer }
- END;
- {--TStream------------------------------------------------------------------}
- { StrRead -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- FUNCTION TStream.StrRead: PChar;
- VAR L: Word; P: PChar;
- BEGIN
- Read(L, SizeOf(L)); { Read length }
- If (L = 0) Then StrRead := Nil Else Begin { Check for empty }
- GetMem(P, L + 1); { Allocate memory }
- If (P <> Nil) Then Begin { Check allocate okay }
- Read(P[0], L); { Read the data }
- P[L] := #0; { Terminate with #0 }
- End;
- StrRead := P; { Return PChar }
- End;
- END;
- {--TStream------------------------------------------------------------------}
- { ReadStr -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- FUNCTION TStream.ReadStr: PString;
- VAR L: Byte; P: PString;
- BEGIN
- Read(L, 1); { Read string length }
- If (L > 0) Then Begin
- GetMem(P, L + 1); { Allocate memory }
- If (P <> Nil) Then Begin { Check allocate okay }
- P^[0] := Char(L); { Hold length }
- Read(P^[1], L); { Read string data }
- End;
- ReadStr := P; { Return string ptr }
- End Else ReadStr := Nil;
- END;
- {--TStream------------------------------------------------------------------}
- { GetPos -> Platforms DOS/DPMI/WIN/OS2 - Checked 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/OS2 - Checked 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/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TStream.Close;
- BEGIN { Abstract method }
- END;
- {--TStream------------------------------------------------------------------}
- { Reset -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TStream.Reset;
- BEGIN
- Status := stOK; { Clear status }
- ErrorInfo := 0; { Clear error info }
- END;
- {--TStream------------------------------------------------------------------}
- { Flush -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TStream.Flush;
- BEGIN { Abstract method }
- END;
- {--TStream------------------------------------------------------------------}
- { Truncate -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TStream.Truncate;
- BEGIN
- Abstract; { Abstract error }
- END;
- {--TStream------------------------------------------------------------------}
- { Put -> Platforms DOS/DPMI/WIN/OS2 - Checked 02Sep97 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TStream.Put (P: PObject);
- VAR ObjType: Sw_Word; Link: pointer; Q: PStreamRec; VmtPtr: ^pointer;
- ObjTypeWord: Word;
- BEGIN
- VmtPtr := Pointer(P); { Xfer object to ptr }
- if assigned(vmtptr) then
- Link := VmtPtr^ { VMT link }
- else
- Link:=nil;
- ObjType := 0; { Set objtype to zero }
- If (P<>Nil) AND (Link<>Nil) Then Begin { We have a VMT link }
- Q := StreamTypes; { Current reg list }
- While (Q <> Nil) AND (Q^.VMTLink <> Link) { Find link match OR }
- 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;
- If TPCompatible Then Begin
- ObjTypeWord := word(ObjType);
- Write(ObjTypeWord, SizeOf(ObjTypeWord))
- end
- else
- Write(ObjType, SizeOf(ObjType)); { Write object type }
- If (ObjType<>0) Then { Registered object }
- CallPointerMethod(Q^.Store, P, @Self);
- END;
- {--TStream------------------------------------------------------------------}
- { Seek -> Platforms DOS/DPMI/WIN/OS2 - Checked 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/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TStream.StrWrite (P: PChar);
- VAR L: Word; Q: PByteArray;
- BEGIN
- L := 0; { Preset zero size }
- Q := PByteArray(P); { Transfer type }
- If (Q <> Nil) Then While (Q^[L] <> 0) Do Inc(L); { PChar length }
- Write(L, SizeOf(L)); { Store length }
- If (P <> Nil) Then Write(P[0], L); { Write data }
- END;
- {--TStream------------------------------------------------------------------}
- { WriteStr -> Platforms DOS/DPMI/WIN/OS2 - Checked 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/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TStream.Open (OpenMode: Word);
- BEGIN { Abstract method }
- END;
- {--TStream------------------------------------------------------------------}
- { Error -> Platforms DOS/DPMI/WIN/OS2 - Checked 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/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TStream.Read (Var Buf; Count: Longint);
- BEGIN
- Abstract; { Abstract error }
- END;
- {--TStream------------------------------------------------------------------}
- { Write -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TStream.Write (Var Buf; Count: Longint);
- BEGIN
- Abstract; { Abstract error }
- END;
- {--TStream------------------------------------------------------------------}
- { CopyFrom -> Platforms DOS/DPMI/WIN/OS2 - Checked 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 }
- {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
- {$PUSH}
- {$I-}
- {--TDosStream---------------------------------------------------------------}
- { Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
- {---------------------------------------------------------------------------}
- CONSTRUCTOR TDosStream.Init (FileName: FNameStr; Mode: Word);
- VAR OldFileMode : Byte;
- DosStreamError : Word;
- BEGIN
- Inherited Init; { Call ancestor }
- FileName := FileName+#0; { Make asciiz }
- Move(FileName[1], FName, Length(FileName)); { Create asciiz name }
- Handle := InvalidHandle;
- Assign(FileInfo,FileName);
- { Handle the mode }
- if Mode =stCreate then
- Begin
- Rewrite(FileInfo,1);
- end
- else
- Begin
- OldFileMode := FileMode;
- { Keep sharing modes! }
- FileMode := Mode and $FF;
- System.Reset(FileInfo,1);
- FileMode := OldFileMode;
- { To use the correct mode we must reclose the file
- and open it again
- }
- end;
- Handle := FileRec(FileInfo).Handle; { Set handle value }
- DosStreamError := IOResult;
- If DosStreamError = 0 then
- Begin
- StreamSize := System.FileSize(FileInfo);
- end;
- If DosStreamError = 0 then
- DosStreamError := IOResult;
- If (DosStreamError <> 0) Then
- Error(stInitError, DosStreamError) { Call stream error }
- else
- Status := StOK;
- END;
- {--TDosStream---------------------------------------------------------------}
- { Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
- {---------------------------------------------------------------------------}
- DESTRUCTOR TDosStream.Done;
- var
- DosStreamError : Word;
- BEGIN
- if Handle <> InvalidHandle then
- Begin
- System.Close(FileInfo);
- DosStreamError := IOResult;
- If DosStreamError = 0 then
- Status := stOk
- else
- Error(stError, DosStreamError);
- end;
- Position := 0; { Zero the position }
- Handle := InvalidHandle;
- Inherited Done; { Call ancestor }
- END;
- {--TDosStream---------------------------------------------------------------}
- { Close -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TDosStream.Close;
- var
- DosStreamError : Word;
- BEGIN
- if Handle <> InvalidHandle then { Is file closed ? }
- Begin
- System.Close(FileInfo); { Close file }
- DosStreamError := IOResult; { Check for error }
- If DosStreamError = 0 then
- Status := stOk
- else
- Error(stError, DosStreamError); { Call error routine }
- end;
- Position := 0; { Zero the position }
- Handle := InvalidHandle; { Handle invalid }
- END;
- {--TDosStream---------------------------------------------------------------}
- { Truncate -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TDosStream.Truncate;
- var
- DosStreamError : Word;
- BEGIN
- If Status = stOk then
- Begin
- System.Truncate(FileInfo);
- DosStreamError := IOResult;
- If DosStreamError = 0 then
- { Status is already = stOK }
- StreamSize := Position
- else
- Error(stError, DosStreamError);
- end;
- END;
- {--TDosStream---------------------------------------------------------------}
- { Seek -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TDosStream.Seek (Pos: Longint);
- var
- DosStreamError : Word;
- BEGIN
- If (Status=stOk) Then
- Begin { Check status okay }
- If (Pos < 0) Then
- Pos := 0; { Negatives removed }
- System.Seek(FileInfo, Pos);
- DosStreamError := IOResult;
- if DosStreamError <> 0 then
- Error(stSeekError, DosStreamError){ Specific seek error }
- Else Position := Pos; { Adjust position }
- { Status is already = stOK }
- End;
- END;
- {--TDosStream---------------------------------------------------------------}
- { Open -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TDosStream.Open (OpenMode: Word);
- VAR OldFileMode : Byte;
- DosStreamError : Word;
- BEGIN
- If (Status=stOk) Then
- Begin { Check status okay }
- If (Handle = InvalidHandle) Then
- Begin { File not open }
- Assign(FileInfo,FName);
- { Handle the mode }
- if OpenMode =stCreate then
- Begin
- System.Rewrite(FileInfo,1);
- end
- else
- Begin
- OldFileMode := FileMode;
- FileMode := OpenMode and 3;
- System.Reset(FileInfo,1);
- FileMode := OldFileMode;
- { To use the correct mode we must reclose the file
- and open it again
- }
- end;
- Handle := FileRec(FileInfo).Handle; { Set handle value }
- DosStreamError := IOResult;
- If DosStreamError = 0 then
- StreamSize := System.FileSize(FileInfo);
- If DosStreamError = 0 then
- DosStreamError := IOResult;
- If (DosStreamError <> 0) Then
- Error(stOpenError, DosStreamError) { Call stream error }
- else
- Status := StOK;
- Position := 0;
- end
- Else
- Error(stOpenError, 104); { File already open }
- End;
- END;
- {--TDosStream---------------------------------------------------------------}
- { Read -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
- {---------------------------------------------------------------------------}
- PROCEDURE TDosStream.Read (Var Buf; Count: Longint);
- VAR BytesMoved: Longint;
- DosStreamError : Word;
- BEGIN
- If Status = StOK then
- Begin
- If (Position + Count > StreamSize) Then { Insufficient data }
- Error(stReadError, 0); { Read beyond end!!! }
- If (Handle = InvalidHandle) Then
- Error(stReadError, 103); { File not open }
- BlockRead(FileInfo, Buf, Count, BytesMoved); { Read from file }
- DosStreamError := IOResult;
- If ((DosStreamError<>0) OR (BytesMoved<>Count)) Then
- Begin { Error was detected }
- BytesMoved := 0; { Clear bytes moved }
- If (DosStreamError <> 0) Then
- Error(stReadError, DosStreamError) { Specific read error }
- Else
- Error(stReadError, 0); { Non specific error }
- End;
- Inc(Position, BytesMoved); { Adjust position }
- End;
- { If there was already an error, or an error was just
- generated, fill the vuffer with NULL
- }
- If Status <> StOK then
- FillChar(Buf, Count, #0); { Error clear buffer }
- END;
- {--TDosStream---------------