objects.pp 137 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2000 by the Free Pascal development team.
  4. Objects.pas clone for Free Pascal
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. {************[ SOURCE FILE OF FREE VISION ]****************}
  12. { }
  13. { System independent clone of objects.pas }
  14. { }
  15. { Interface Copyright (c) 1992 Borland International }
  16. { }
  17. { Parts Copyright (c) 1999-2000 by Florian Klaempfl }
  18. { [email protected] }
  19. { }
  20. { Parts Copyright (c) 1999-2000 by Frank ZAGO }
  21. { [email protected] }
  22. { }
  23. { Parts Copyright (c) 1999-2000 by MH Spiegel }
  24. { }
  25. { Parts Copyright (c) 1996, 1999-2000 by Leon de Boer }
  26. { [email protected] }
  27. { }
  28. { Free Vision project coordinator Balazs Scheidler }
  29. { [email protected] }
  30. { }
  31. UNIT Objects;
  32. {<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
  33. INTERFACE
  34. {<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
  35. {==== Select assembler ==============================================}
  36. {$IFDEF CPU86}
  37. {$ASMMODE ATT}
  38. {$ENDIF}
  39. {==== Compiler directives ===========================================}
  40. {$H-} { No ansistrings }
  41. {$X+} { Extended syntax is ok }
  42. {$R-} { Disable range checking }
  43. {$ifndef Unix}
  44. {$S-} { Disable Stack Checking }
  45. {$endif}
  46. {$I-} { Disable IO Checking }
  47. {$Q-} { Disable Overflow Checking }
  48. {$V-} { Turn off strict VAR strings }
  49. {$INLINE ON} {Turn on inlining.}
  50. {====================================================================}
  51. {$ifdef win32}
  52. uses
  53. Windows;
  54. {$endif}
  55. {***************************************************************************}
  56. { PUBLIC CONSTANTS }
  57. {***************************************************************************}
  58. {---------------------------------------------------------------------------}
  59. { STREAM ERROR STATE MASKS }
  60. {---------------------------------------------------------------------------}
  61. CONST
  62. stOk = 0; { No stream error }
  63. stError = -1; { Access error }
  64. stInitError = -2; { Initialize error }
  65. stReadError = -3; { Stream read error }
  66. stWriteError = -4; { Stream write error }
  67. stGetError = -5; { Get object error }
  68. stPutError = -6; { Put object error }
  69. stSeekError = -7; { Seek error in stream }
  70. stOpenError = -8; { Error opening stream }
  71. {---------------------------------------------------------------------------}
  72. { STREAM ACCESS MODE CONSTANTS }
  73. {---------------------------------------------------------------------------}
  74. CONST
  75. stCreate = $3C00; { Create new file }
  76. stOpenRead = $3D00; { Read access only }
  77. stOpenWrite = $3D01; { Write access only }
  78. stOpen = $3D02; { Read/write access }
  79. {---------------------------------------------------------------------------}
  80. { TCollection ERROR CODES }
  81. {---------------------------------------------------------------------------}
  82. CONST
  83. coIndexError = -1; { Index out of range }
  84. coOverflow = -2; { Overflow }
  85. {---------------------------------------------------------------------------}
  86. { VMT HEADER CONSTANT - HOPEFULLY WE CAN DROP THIS LATER }
  87. {---------------------------------------------------------------------------}
  88. CONST
  89. vmtHeaderSize = 8; { VMT header size }
  90. CONST
  91. {---------------------------------------------------------------------------}
  92. { MAXIUM DATA SIZES }
  93. {---------------------------------------------------------------------------}
  94. {$IFDEF FPC}
  95. {$IFDEF CPU16}
  96. MaxBytes = 16384;
  97. {$ELSE CPU16}
  98. MaxBytes = 128*1024*128; { Maximum data size }
  99. {$ENDIF CPU16}
  100. {$ELSE}
  101. MaxBytes = 16384;
  102. {$ENDIF}
  103. MaxWords = MaxBytes DIV SizeOf(Word); { Max word data size }
  104. MaxPtrs = MaxBytes DIV SizeOf(Pointer); { Max ptr data size }
  105. MaxCollectionSize = MaxBytes DIV SizeOf(Pointer); { Max collection size }
  106. MaxTPCompatibleCollectionSize = 65520 div 4;
  107. {***************************************************************************}
  108. { PUBLIC TYPE DEFINITIONS }
  109. {***************************************************************************}
  110. {---------------------------------------------------------------------------}
  111. { CHARACTER SET }
  112. {---------------------------------------------------------------------------}
  113. TYPE
  114. TCharSet = SET Of Char; { Character set }
  115. PCharSet = ^TCharSet; { Character set ptr }
  116. {---------------------------------------------------------------------------}
  117. { GENERAL ARRAYS }
  118. {---------------------------------------------------------------------------}
  119. TYPE
  120. TByteArray = ARRAY [0..MaxBytes-1] Of Byte; { Byte array }
  121. PByteArray = ^TByteArray; { Byte array pointer }
  122. TWordArray = ARRAY [0..MaxWords-1] Of Word; { Word array }
  123. PWordArray = ^TWordArray; { Word array pointer }
  124. TPointerArray = Array [0..MaxPtrs-1] Of Pointer; { Pointer array }
  125. PPointerArray = ^TPointerArray; { Pointer array ptr }
  126. {---------------------------------------------------------------------------}
  127. { POINTER TO STRING }
  128. {---------------------------------------------------------------------------}
  129. TYPE
  130. PString = PShortString; { String pointer }
  131. {---------------------------------------------------------------------------}
  132. { OS dependent File type / consts }
  133. {---------------------------------------------------------------------------}
  134. type
  135. FNameStr = String;
  136. const
  137. MaxReadBytes = $7fffffff;
  138. var
  139. invalidhandle : THandle;
  140. {---------------------------------------------------------------------------}
  141. { DOS ASCIIZ FILENAME }
  142. {---------------------------------------------------------------------------}
  143. TYPE
  144. AsciiZ = Array [0..255] Of Char; { Filename array }
  145. {---------------------------------------------------------------------------}
  146. { BIT SWITCHED TYPE CONSTANTS }
  147. {---------------------------------------------------------------------------}
  148. TYPE
  149. {$ifdef CPU16}
  150. Sw_Word = Word;
  151. Sw_Integer = SmallInt;
  152. {$else CPU16}
  153. Sw_Word = Cardinal; { Long Word now }
  154. Sw_Integer = LongInt; { Long integer now }
  155. {$endif CPU16}
  156. {***************************************************************************}
  157. { PUBLIC RECORD DEFINITIONS }
  158. {***************************************************************************}
  159. {---------------------------------------------------------------------------}
  160. { TYPE CONVERSION RECORDS }
  161. {---------------------------------------------------------------------------}
  162. TYPE
  163. WordRec = packed RECORD
  164. {$ifdef ENDIAN_LITTLE}
  165. Lo, Hi: Byte; { Word to bytes }
  166. {$else}
  167. Hi,Lo: Byte;
  168. {$endif}
  169. END;
  170. LongRec = packed RECORD
  171. {$ifdef ENDIAN_LITTLE}
  172. Lo, Hi: Word; { LongInt to words }
  173. {$else}
  174. Hi,Lo: Word; { LongInt to words }
  175. {$endif}
  176. END;
  177. PtrRec = packed RECORD
  178. Ofs, Seg: Word; { Pointer to words }
  179. END;
  180. {---------------------------------------------------------------------------}
  181. { TStreamRec RECORD - STREAM OBJECT RECORD }
  182. {---------------------------------------------------------------------------}
  183. TYPE
  184. PStreamRec = ^TStreamRec; { Stream record ptr }
  185. TStreamRec = Packed RECORD
  186. ObjType: Sw_Word; { Object type id }
  187. VmtLink: pointer; { VMT link }
  188. Load : CodePointer; { Object load code }
  189. Store: CodePointer; { Object store code }
  190. Next : PStreamRec; { Next stream record }
  191. END;
  192. {***************************************************************************}
  193. { PUBLIC OBJECT DEFINITIONS }
  194. {***************************************************************************}
  195. {---------------------------------------------------------------------------}
  196. { TPoint OBJECT - POINT OBJECT }
  197. {---------------------------------------------------------------------------}
  198. TYPE
  199. PPoint = ^TPoint;
  200. TPoint = OBJECT
  201. X, Y: Sw_Integer;
  202. END;
  203. {---------------------------------------------------------------------------}
  204. { TRect OBJECT - RECTANGLE OBJECT }
  205. {---------------------------------------------------------------------------}
  206. PRect = ^TRect;
  207. TRect = OBJECT
  208. A, B: TPoint; { Corner points }
  209. FUNCTION Empty: Boolean;
  210. FUNCTION Equals (R: TRect): Boolean;
  211. FUNCTION Contains (P: TPoint): Boolean;
  212. PROCEDURE Copy (R: TRect);
  213. PROCEDURE Union (R: TRect);
  214. PROCEDURE Intersect (R: TRect);
  215. PROCEDURE Move (ADX, ADY: Sw_Integer);
  216. PROCEDURE Grow (ADX, ADY: Sw_Integer);
  217. PROCEDURE Assign (XA, YA, XB, YB: Sw_Integer);
  218. END;
  219. {---------------------------------------------------------------------------}
  220. { TObject OBJECT - BASE ANCESTOR OBJECT }
  221. {---------------------------------------------------------------------------}
  222. TYPE
  223. TObject = OBJECT
  224. CONSTRUCTOR Init;
  225. PROCEDURE Free;
  226. FUNCTION Is_Object(P:Pointer):Boolean;
  227. DESTRUCTOR Done; Virtual;
  228. END;
  229. PObject = ^TObject;
  230. { ******************************* REMARK ****************************** }
  231. { Two new virtual methods have been added to the object in the form of }
  232. { Close and Open. The main use here is in the Disk Based Descendants }
  233. { the calls open and close the given file so these objects can be }
  234. { used like standard files. Two new fields have also been added to }
  235. { speed up seeks on descendants. All existing code will compile and }
  236. { work completely normally oblivious to these new methods and fields. }
  237. { ****************************** END REMARK *** Leon de Boer, 15May96 * }
  238. {---------------------------------------------------------------------------}
  239. { TStream OBJECT - STREAM ANCESTOR OBJECT }
  240. {---------------------------------------------------------------------------}
  241. TYPE
  242. TStream = OBJECT (TObject)
  243. Status : Integer; { Stream status }
  244. ErrorInfo : Integer; { Stream error info }
  245. StreamSize: LongInt; { Stream current size }
  246. Position : LongInt; { Current position }
  247. TPCompatible : Boolean;
  248. CONSTRUCTOR Init;
  249. FUNCTION Get: PObject;
  250. FUNCTION StrRead: PChar;
  251. FUNCTION GetPos: Longint; Virtual;
  252. FUNCTION GetSize: Longint; Virtual;
  253. FUNCTION ReadStr: PString;
  254. PROCEDURE Open (OpenMode: Word); Virtual;
  255. PROCEDURE Close; Virtual;
  256. PROCEDURE Reset;
  257. PROCEDURE Flush; Virtual;
  258. PROCEDURE Truncate; Virtual;
  259. PROCEDURE Put (P: PObject);
  260. PROCEDURE StrWrite (P: PChar);
  261. PROCEDURE WriteStr (P: PString);
  262. PROCEDURE Seek (Pos: LongInt); Virtual;
  263. PROCEDURE Error (Code, Info: Integer); Virtual;
  264. PROCEDURE Read (Var Buf; Count: LongInt); Virtual;
  265. PROCEDURE Write (Var Buf; Count: LongInt); Virtual;
  266. PROCEDURE CopyFrom (Var S: TStream; Count: Longint);
  267. END;
  268. PStream = ^TStream;
  269. { ******************************* REMARK ****************************** }
  270. { A few minor changes to this object and an extra field added called }
  271. { FName which holds an AsciiZ array of the filename this allows the }
  272. { streams file to be opened and closed like a normal text file. All }
  273. { existing code should work without any changes. }
  274. { ****************************** END REMARK *** Leon de Boer, 19May96 * }
  275. {---------------------------------------------------------------------------}
  276. { TDosStream OBJECT - DOS FILE STREAM OBJECT }
  277. {---------------------------------------------------------------------------}
  278. TYPE
  279. TDosStream = OBJECT (TStream)
  280. Handle: THandle; { DOS file handle }
  281. FName : AsciiZ; { AsciiZ filename }
  282. CONSTRUCTOR Init (FileName: FNameStr; Mode: Word);
  283. DESTRUCTOR Done; Virtual;
  284. PROCEDURE Close; Virtual;
  285. PROCEDURE Truncate; Virtual;
  286. PROCEDURE Seek (Pos: LongInt); Virtual;
  287. PROCEDURE Open (OpenMode: Word); Virtual;
  288. PROCEDURE Read (Var Buf; Count: Longint); Virtual;
  289. PROCEDURE Write (Var Buf; Count: Longint); Virtual;
  290. private
  291. FileInfo : File;
  292. END;
  293. PDosStream = ^TDosStream;
  294. { ******************************* REMARK ****************************** }
  295. { A few minor changes to this object and an extra field added called }
  296. { lastmode which holds the read or write condition last using the }
  297. { speed up buffer which helps speed up the flush, position and size }
  298. { functions. All existing code should work without any changes. }
  299. { ****************************** END REMARK *** Leon de Boer, 19May96 * }
  300. {---------------------------------------------------------------------------}
  301. { TBufStream OBJECT - BUFFERED DOS FILE STREAM }
  302. {---------------------------------------------------------------------------}
  303. TYPE
  304. TBufStream = OBJECT (TDosStream)
  305. LastMode: Byte; { Last buffer mode }
  306. BufSize : Longint; { Buffer size }
  307. BufPtr : Longint; { Buffer start }
  308. BufEnd : Longint; { Buffer end }
  309. Buffer : PByteArray; { Buffer allocated }
  310. CONSTRUCTOR Init (FileName: FNameStr; Mode, Size: Word);
  311. DESTRUCTOR Done; Virtual;
  312. PROCEDURE Close; Virtual;
  313. PROCEDURE Flush; Virtual;
  314. PROCEDURE Truncate; Virtual;
  315. PROCEDURE Seek (Pos: LongInt); Virtual;
  316. PROCEDURE Open (OpenMode: Word); Virtual;
  317. PROCEDURE Read (Var Buf; Count: Longint); Virtual;
  318. PROCEDURE Write (Var Buf; Count: Longint); Virtual;
  319. END;
  320. PBufStream = ^TBufStream;
  321. { ******************************* REMARK ****************************** }
  322. { All the changes here should be completely transparent to existing }
  323. { code. Basically the memory blocks do not have to be base segments }
  324. { but this means our list becomes memory blocks rather than segments. }
  325. { The stream will also expand like the other standard streams!! }
  326. { ****************************** END REMARK *** Leon de Boer, 19May96 * }
  327. {---------------------------------------------------------------------------}
  328. { TMemoryStream OBJECT - MEMORY STREAM OBJECT }
  329. {---------------------------------------------------------------------------}
  330. TYPE
  331. TMemoryStream = OBJECT (TStream)
  332. BlkCount: Longint; { Number of segments }
  333. BlkSize : Word; { Memory block size }
  334. MemSize : LongInt; { Memory alloc size }
  335. BlkList : PPointerArray; { Memory block list }
  336. CONSTRUCTOR Init (ALimit: Longint; ABlockSize: Word);
  337. DESTRUCTOR Done; Virtual;
  338. PROCEDURE Truncate; Virtual;
  339. PROCEDURE Read (Var Buf; Count: Longint); Virtual;
  340. PROCEDURE Write (Var Buf; Count: Longint); Virtual;
  341. PRIVATE
  342. FUNCTION ChangeListSize (ALimit: Longint): Boolean;
  343. END;
  344. PMemoryStream = ^TMemoryStream;
  345. TYPE
  346. TItemList = Array [0..MaxCollectionSize - 1] Of Pointer;
  347. PItemList = ^TItemList;
  348. { ******************************* REMARK ****************************** }
  349. { The changes here look worse than they are. The Sw_Integer simply }
  350. { switches between Integers and LongInts if switched between 16 and 32 }
  351. { bit code. All existing code will compile without any changes. }
  352. { ****************************** END REMARK *** Leon de Boer, 10May96 * }
  353. {---------------------------------------------------------------------------}
  354. { TCollection OBJECT - COLLECTION ANCESTOR OBJECT }
  355. {---------------------------------------------------------------------------}
  356. TCollection = OBJECT (TObject)
  357. Items: PItemList; { Item list pointer }
  358. Count: Sw_Integer; { Item count }
  359. Limit: Sw_Integer; { Item limit count }
  360. Delta: Sw_Integer; { Inc delta size }
  361. CONSTRUCTOR Init (ALimit, ADelta: Sw_Integer);
  362. CONSTRUCTOR Load (Var S: TStream);
  363. DESTRUCTOR Done; Virtual;
  364. FUNCTION At (Index: Sw_Integer): Pointer;
  365. FUNCTION IndexOf (Item: Pointer): Sw_Integer; Virtual;
  366. FUNCTION GetItem (Var S: TStream): Pointer; Virtual;
  367. FUNCTION LastThat (Test: CodePointer): Pointer;
  368. FUNCTION FirstThat (Test: CodePointer): Pointer;
  369. PROCEDURE Pack;
  370. PROCEDURE FreeAll;
  371. PROCEDURE DeleteAll;
  372. PROCEDURE Free (Item: Pointer);
  373. PROCEDURE Insert (Item: Pointer); Virtual;
  374. PROCEDURE Delete (Item: Pointer);
  375. PROCEDURE AtFree (Index: Sw_Integer);
  376. PROCEDURE FreeItem (Item: Pointer); Virtual;
  377. PROCEDURE AtDelete (Index: Sw_Integer);
  378. PROCEDURE ForEach (Action: CodePointer);
  379. PROCEDURE SetLimit (ALimit: Sw_Integer); Virtual;
  380. PROCEDURE Error (Code, Info: Integer); Virtual;
  381. PROCEDURE AtPut (Index: Sw_Integer; Item: Pointer);
  382. PROCEDURE AtInsert (Index: Sw_Integer; Item: Pointer);
  383. PROCEDURE Store (Var S: TStream);
  384. PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual;
  385. END;
  386. PCollection = ^TCollection;
  387. {---------------------------------------------------------------------------}
  388. { TSortedCollection OBJECT - SORTED COLLECTION ANCESTOR }
  389. {---------------------------------------------------------------------------}
  390. TYPE
  391. TSortedCollection = OBJECT (TCollection)
  392. Duplicates: Boolean; { Duplicates flag }
  393. CONSTRUCTOR Init (ALimit, ADelta: Sw_Integer);
  394. CONSTRUCTOR Load (Var S: TStream);
  395. FUNCTION KeyOf (Item: Pointer): Pointer; Virtual;
  396. FUNCTION IndexOf (Item: Pointer): Sw_Integer; Virtual;
  397. FUNCTION Compare (Key1, Key2: Pointer): Sw_Integer; Virtual;
  398. FUNCTION Search (Key: Pointer; Var Index: Sw_Integer): Boolean;Virtual;
  399. PROCEDURE Insert (Item: Pointer); Virtual;
  400. PROCEDURE Store (Var S: TStream);
  401. END;
  402. PSortedCollection = ^TSortedCollection;
  403. {---------------------------------------------------------------------------}
  404. { TStringCollection OBJECT - STRING COLLECTION OBJECT }
  405. {---------------------------------------------------------------------------}
  406. TYPE
  407. TStringCollection = OBJECT (TSortedCollection)
  408. FUNCTION GetItem (Var S: TStream): Pointer; Virtual;
  409. FUNCTION Compare (Key1, Key2: Pointer): Sw_Integer; Virtual;
  410. PROCEDURE FreeItem (Item: Pointer); Virtual;
  411. PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual;
  412. END;
  413. PStringCollection = ^TStringCollection;
  414. {---------------------------------------------------------------------------}
  415. { TStrCollection OBJECT - STRING COLLECTION OBJECT }
  416. {---------------------------------------------------------------------------}
  417. TYPE
  418. TStrCollection = OBJECT (TSortedCollection)
  419. FUNCTION Compare (Key1, Key2: Pointer): Sw_Integer; Virtual;
  420. FUNCTION GetItem (Var S: TStream): Pointer; Virtual;
  421. PROCEDURE FreeItem (Item: Pointer); Virtual;
  422. PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual;
  423. END;
  424. PStrCollection = ^TStrCollection;
  425. { ******************************* REMARK ****************************** }
  426. { This is a completely >> NEW << object which holds a collection of }
  427. { strings but does not alphabetically sort them. It is a very useful }
  428. { object for insert ordered list boxes! }
  429. { ****************************** END REMARK *** Leon de Boer, 15May96 * }
  430. {---------------------------------------------------------------------------}
  431. { TUnSortedStrCollection - UNSORTED STRING COLLECTION OBJECT }
  432. {---------------------------------------------------------------------------}
  433. TYPE
  434. TUnSortedStrCollection = OBJECT (TStringCollection)
  435. PROCEDURE Insert (Item: Pointer); Virtual;
  436. END;
  437. PUnSortedStrCollection = ^TUnSortedStrCollection;
  438. {---------------------------------------------------------------------------}
  439. { TResourceCollection OBJECT - RESOURCE COLLECTION OBJECT }
  440. {---------------------------------------------------------------------------}
  441. TYPE
  442. TResourceCollection = OBJECT (TStringCollection)
  443. FUNCTION KeyOf (Item: Pointer): Pointer; Virtual;
  444. FUNCTION GetItem (Var S: TStream): Pointer; Virtual;
  445. PROCEDURE FreeItem (Item: Pointer); Virtual;
  446. PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual;
  447. END;
  448. PResourceCollection = ^TResourceCollection;
  449. {---------------------------------------------------------------------------}
  450. { TResourceFile OBJECT - RESOURCE FILE OBJECT }
  451. {---------------------------------------------------------------------------}
  452. TYPE
  453. TResourceFile = OBJECT (TObject)
  454. Stream : PStream; { File as a stream }
  455. Modified: Boolean; { Modified flag }
  456. CONSTRUCTOR Init (AStream: PStream);
  457. DESTRUCTOR Done; Virtual;
  458. FUNCTION Count: Sw_Integer;
  459. FUNCTION KeyAt (I: Sw_Integer): String;
  460. FUNCTION Get (Key: String): PObject;
  461. FUNCTION SwitchTo (AStream: PStream; Pack: Boolean): PStream;
  462. PROCEDURE Flush;
  463. PROCEDURE Delete (Key: String);
  464. PROCEDURE Put (Item: PObject; Key: String);
  465. PRIVATE
  466. BasePos: LongInt; { Base position }
  467. IndexPos: LongInt; { Index position }
  468. Index: TResourceCollection; { Index collection }
  469. END;
  470. PResourceFile = ^TResourceFile;
  471. TYPE
  472. TStrIndexRec = Packed RECORD
  473. Key : Sw_word;
  474. Count, Offset: Word;
  475. END;
  476. TStrIndex = Array [0..{$ifdef CPU16}MaxBytes div SizeOf(TStrIndexRec){$else}9999{$endif}] Of TStrIndexRec;
  477. PStrIndex = ^TStrIndex;
  478. {---------------------------------------------------------------------------}
  479. { TStringList OBJECT - STRING LIST OBJECT }
  480. {---------------------------------------------------------------------------}
  481. TStringList = OBJECT (TObject)
  482. CONSTRUCTOR Load (Var S: TStream);
  483. DESTRUCTOR Done; Virtual;
  484. FUNCTION Get (Key: Sw_Word): String;
  485. PRIVATE
  486. Stream : PStream;
  487. BasePos : Longint;
  488. IndexSize: Longint;
  489. Index : PStrIndex;
  490. PROCEDURE ReadStr (Var S: String; Offset, Skip: Longint);
  491. END;
  492. PStringList = ^TStringList;
  493. {---------------------------------------------------------------------------}
  494. { TStrListMaker OBJECT - RESOURCE FILE OBJECT }
  495. {---------------------------------------------------------------------------}
  496. TYPE
  497. TStrListMaker = OBJECT (TObject)
  498. CONSTRUCTOR Init (AStrSize, AIndexSize: Sw_Word);
  499. DESTRUCTOR Done; Virtual;
  500. PROCEDURE Put (Key: Sw_Word; S: String);
  501. PROCEDURE Store (Var S: TStream);
  502. PRIVATE
  503. StrPos : Sw_Word;
  504. StrSize : Sw_Word;
  505. Strings : PByteArray;
  506. IndexPos : Sw_Word;
  507. IndexSize: Sw_Word;
  508. Index : PStrIndex;
  509. Cur : TStrIndexRec;
  510. PROCEDURE CloseCurrent;
  511. END;
  512. PStrListMaker = ^TStrListMaker;
  513. {***************************************************************************}
  514. { INTERFACE ROUTINES }
  515. {***************************************************************************}
  516. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  517. { CALL HELPERS INTERFACE ROUTINES }
  518. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  519. { Constructor calls.
  520. Ctor Pointer to the constructor.
  521. Obj Pointer to the instance. NIL if new instance to be allocated.
  522. VMT Pointer to the VMT (obtained by TypeOf()).
  523. returns Pointer to the instance.
  524. }
  525. function CallVoidConstructor(Ctor: codepointer; Obj: pointer; VMT: pointer): pointer;inline;
  526. function CallPointerConstructor(Ctor: codepointer; Obj: pointer; VMT: pointer; Param1: pointer): pointer;inline;
  527. { Method calls.
  528. Method Pointer to the method.
  529. Obj Pointer to the instance. NIL if new instance to be allocated.
  530. returns Pointer to the instance.
  531. }
  532. function CallVoidMethod(Method: codepointer; Obj: pointer): pointer;inline;
  533. function CallPointerMethod(Method: codepointer; Obj: pointer; Param1: pointer): pointer;inline;
  534. { Local-function/procedure calls.
  535. Func Pointer to the local function (which must be far-coded).
  536. Frame Frame pointer of the wrapping function.
  537. }
  538. function CallVoidLocal(Func: codepointer; Frame: Pointer): pointer;inline;
  539. function CallPointerLocal(Func: codepointer; Frame: Pointer; Param1: pointer): pointer;inline;
  540. { Calls of functions/procedures local to methods.
  541. Func Pointer to the local function (which must be far-coded).
  542. Frame Frame pointer of the wrapping method.
  543. Obj Pointer to the object that the method belongs to.
  544. }
  545. function CallVoidMethodLocal(Func: codepointer; Frame: Pointer; Obj: pointer): pointer;inline;
  546. function CallPointerMethodLocal(Func: codepointer; Frame: Pointer; Obj: pointer; Param1: pointer): pointer;inline;
  547. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  548. { DYNAMIC STRING INTERFACE ROUTINES }
  549. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  550. {-NewStr-------------------------------------------------------------
  551. Allocates a dynamic string into memory. If S is nil, NewStr returns
  552. a nil pointer, otherwise NewStr allocates Length(S)+1 bytes of memory
  553. containing a copy of S, and returns a pointer to the string.
  554. 12Jun96 LdB
  555. ---------------------------------------------------------------------}
  556. FUNCTION NewStr (Const S: String): PString;
  557. {-DisposeStr---------------------------------------------------------
  558. Disposes of a PString allocated by the function NewStr.
  559. 12Jun96 LdB
  560. ---------------------------------------------------------------------}
  561. PROCEDURE DisposeStr (P: PString);
  562. PROCEDURE SetStr(VAR p:pString; CONST s:STRING);
  563. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  564. { STREAM INTERFACE ROUTINES }
  565. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  566. {-Abstract-----------------------------------------------------------
  567. Terminates program with a run-time error 211. When implementing
  568. an abstract object type, call Abstract in those virtual methods that
  569. must be overridden in descendant types. This ensures that any
  570. attempt to use instances of the abstract object type will fail.
  571. 12Jun96 LdB
  572. ---------------------------------------------------------------------}
  573. PROCEDURE Abstract;
  574. {-RegisterObjects----------------------------------------------------
  575. Registers the three standard objects TCollection, TStringCollection
  576. and TStrCollection.
  577. 02Sep97 LdB
  578. ---------------------------------------------------------------------}
  579. PROCEDURE RegisterObjects;
  580. {-RegisterType-------------------------------------------------------
  581. Registers the given object type with Free Vision's streams, creating
  582. a list of known objects. Streams can only store and return these known
  583. object types. Each registered object needs a unique stream registration
  584. record, of type TStreamRec.
  585. 02Sep97 LdB
  586. ---------------------------------------------------------------------}
  587. PROCEDURE RegisterType (Var S: TStreamRec);
  588. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  589. { GENERAL FUNCTION INTERFACE ROUTINES }
  590. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  591. {-LongMul------------------------------------------------------------
  592. Returns the long integer value of X * Y integer values.
  593. 04Sep97 LdB
  594. ---------------------------------------------------------------------}
  595. FUNCTION LongMul (X, Y: Integer): LongInt;
  596. {-LongDiv------------------------------------------------------------
  597. Returns the integer value of long integer X divided by integer Y.
  598. 04Sep97 LdB
  599. ---------------------------------------------------------------------}
  600. FUNCTION LongDiv (X: Longint; Y: Integer): Integer;
  601. {***************************************************************************}
  602. { PUBLIC INITIALIZED VARIABLES }
  603. {***************************************************************************}
  604. CONST
  605. {---------------------------------------------------------------------------}
  606. { INITIALIZED DOS/DPMI/WIN/OS2 PUBLIC VARIABLES }
  607. {---------------------------------------------------------------------------}
  608. StreamError: CodePointer = Nil; { Stream error ptr }
  609. DefaultTPCompatible: Boolean = false;
  610. {---------------------------------------------------------------------------}
  611. { STREAM REGISTRATION RECORDS }
  612. {---------------------------------------------------------------------------}
  613. CONST
  614. RCollection: TStreamRec = (
  615. ObjType: 50;
  616. VmtLink: Ofs(TypeOf(TCollection)^);
  617. Load: @TCollection.Load;
  618. Store: @TCollection.Store;
  619. Next: Nil);
  620. RStringCollection: TStreamRec = (
  621. ObjType: 51;
  622. VmtLink: Ofs(TypeOf(TStringCollection)^);
  623. Load: @TStringCollection.Load;
  624. Store: @TStringCollection.Store;
  625. Next: Nil);
  626. RStrCollection: TStreamRec = (
  627. ObjType: 69;
  628. VmtLink: Ofs(TypeOf(TStrCollection)^);
  629. Load: @TStrCollection.Load;
  630. Store: @TStrCollection.Store;
  631. Next: Nil);
  632. RStringList: TStreamRec = (
  633. ObjType: 52;
  634. VmtLink: Ofs(TypeOf(TStringList)^);
  635. Load: @TStringList.Load;
  636. Store: Nil;
  637. Next: Nil);
  638. RStrListMaker: TStreamRec = (
  639. ObjType: 52;
  640. VmtLink: Ofs(TypeOf(TStrListMaker)^);
  641. Load: Nil;
  642. Store: @TStrListMaker.Store;
  643. Next: Nil);
  644. {<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
  645. IMPLEMENTATION
  646. {<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
  647. {***************************************************************************}
  648. { HELPER ROUTINES FOR CALLING }
  649. {***************************************************************************}
  650. type
  651. {$ifdef cpui8086}
  652. VoidLocal = function(_BP: Word): pointer;
  653. PointerLocal = function(_BP: Word; Param1: pointer): pointer;
  654. VoidMethodLocal = function(_BP: Word): pointer;
  655. PointerMethodLocal = function(_BP: Word; Param1: pointer): pointer;
  656. {$else cpui8086}
  657. VoidLocal = function(_EBP: Pointer): pointer;
  658. PointerLocal = function(_EBP: Pointer; Param1: pointer): pointer;
  659. VoidMethodLocal = function(_EBP: Pointer): pointer;
  660. PointerMethodLocal = function(_EBP: Pointer; Param1: pointer): pointer;
  661. {$endif cpui8086}
  662. VoidConstructor = function(VMT: pointer; Obj: pointer): pointer;
  663. PointerConstructor = function(VMT: pointer; Obj: pointer; Param1: pointer): pointer;
  664. VoidMethod = function(Obj: pointer): pointer;
  665. PointerMethod = function(Obj: pointer; Param1: pointer): pointer;
  666. function CallVoidConstructor(Ctor: codepointer; Obj: pointer; VMT: pointer): pointer;inline;
  667. begin
  668. CallVoidConstructor := VoidConstructor(Ctor)(Obj, VMT);
  669. end;
  670. function CallPointerConstructor(Ctor: codepointer; Obj: pointer; VMT: pointer; Param1: pointer): pointer;inline;
  671. {$undef FPC_CallPointerConstructor_Implemented}
  672. begin
  673. {$define FPC_CallPointerConstructor_Implemented}
  674. CallPointerConstructor := PointerConstructor(Ctor)(Obj, VMT, Param1)
  675. end;
  676. {$ifndef FPC_CallPointerConstructor_Implemented}
  677. {$error CallPointerConstructor function not implemented}
  678. {$endif not FPC_CallPointerConstructor_Implemented}
  679. function CallVoidMethod(Method: codepointer; Obj: pointer): pointer;inline;
  680. begin
  681. CallVoidMethod := VoidMethod(Method)(Obj)
  682. end;
  683. function CallPointerMethod(Method: codepointer; Obj: pointer; Param1: pointer): pointer;inline;
  684. {$undef FPC_CallPointerMethod_Implemented}
  685. begin
  686. {$define FPC_CallPointerMethod_Implemented}
  687. CallPointerMethod := PointerMethod(Method)(Obj, Param1)
  688. end;
  689. {$ifndef FPC_CallPointerMethod_Implemented}
  690. {$error CallPointerMethod function not implemented}
  691. {$endif not FPC_CallPointerMethod_Implemented}
  692. function CallVoidLocal(Func: codepointer; Frame: Pointer): pointer;inline;
  693. begin
  694. {$ifdef cpui8086}
  695. CallVoidLocal := VoidLocal(Func)(Ofs(Frame^))
  696. {$else cpui8086}
  697. CallVoidLocal := VoidLocal(Func)(Frame)
  698. {$endif cpui8086}
  699. end;
  700. function CallPointerLocal(Func: codepointer; Frame: Pointer; Param1: pointer): pointer;inline;
  701. begin
  702. {$ifdef cpui8086}
  703. CallPointerLocal := PointerLocal(Func)(Ofs(Frame^), Param1)
  704. {$else cpui8086}
  705. CallPointerLocal := PointerLocal(Func)(Frame, Param1)
  706. {$endif cpui8086}
  707. end;
  708. function CallVoidMethodLocal(Func: codepointer; Frame: Pointer; Obj: pointer): pointer;inline;
  709. begin
  710. {$ifdef cpui8086}
  711. CallVoidMethodLocal := VoidMethodLocal(Func)(Ofs(Frame^))
  712. {$else cpui8086}
  713. CallVoidMethodLocal := VoidMethodLocal(Func)(Frame)
  714. {$endif cpui8086}
  715. end;
  716. function CallPointerMethodLocal(Func: codepointer; Frame: Pointer; Obj: pointer; Param1: pointer): pointer;inline;
  717. begin
  718. {$ifdef cpui8086}
  719. CallPointerMethodLocal := PointerMethodLocal(Func)(Ofs(Frame^), Param1)
  720. {$else cpui8086}
  721. CallPointerMethodLocal := PointerMethodLocal(Func)(Frame, Param1)
  722. {$endif cpui8086}
  723. end;
  724. {***************************************************************************}
  725. { PRIVATE INITIALIZED VARIABLES }
  726. {***************************************************************************}
  727. {---------------------------------------------------------------------------}
  728. { INITIALIZED DOS/DPMI/WIN/OS2 PRIVATE VARIABLES }
  729. {---------------------------------------------------------------------------}
  730. CONST
  731. StreamTypes: PStreamRec = Nil; { Stream types reg }
  732. {***************************************************************************}
  733. { PRIVATE INTERNAL ROUTINES }
  734. {***************************************************************************}
  735. {---------------------------------------------------------------------------}
  736. { RegisterError -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 12Jun96 LdB }
  737. {---------------------------------------------------------------------------}
  738. PROCEDURE RegisterError;
  739. BEGIN
  740. RunError(212); { Register error }
  741. END;
  742. {***************************************************************************}
  743. { OBJECT METHODS }
  744. {***************************************************************************}
  745. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  746. { TRect OBJECT METHODS }
  747. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  748. PROCEDURE CheckEmpty (Var Rect: TRect);
  749. BEGIN
  750. With Rect Do Begin
  751. If (A.X >= B.X) OR (A.Y >= B.Y) Then Begin { Zero or reversed }
  752. A.X := 0; { Clear a.x }
  753. A.Y := 0; { Clear a.y }
  754. B.X := 0; { Clear b.x }
  755. B.Y := 0; { Clear b.y }
  756. End;
  757. End;
  758. END;
  759. {--TRect--------------------------------------------------------------------}
  760. { Empty -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  761. {---------------------------------------------------------------------------}
  762. FUNCTION TRect.Empty: Boolean;
  763. BEGIN
  764. Empty := (A.X >= B.X) OR (A.Y >= B.Y); { Empty result }
  765. END;
  766. {--TRect--------------------------------------------------------------------}
  767. { Equals -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  768. {---------------------------------------------------------------------------}
  769. FUNCTION TRect.Equals (R: TRect): Boolean;
  770. BEGIN
  771. Equals := (A.X = R.A.X) AND (A.Y = R.A.Y) AND
  772. (B.X = R.B.X) AND (B.Y = R.B.Y); { Equals result }
  773. END;
  774. {--TRect--------------------------------------------------------------------}
  775. { Contains -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  776. {---------------------------------------------------------------------------}
  777. FUNCTION TRect.Contains (P: TPoint): Boolean;
  778. BEGIN
  779. Contains := (P.X >= A.X) AND (P.X < B.X) AND
  780. (P.Y >= A.Y) AND (P.Y < B.Y); { Contains result }
  781. END;
  782. {--TRect--------------------------------------------------------------------}
  783. { Copy -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  784. {---------------------------------------------------------------------------}
  785. PROCEDURE TRect.Copy (R: TRect);
  786. BEGIN
  787. A := R.A; { Copy point a }
  788. B := R.B; { Copy point b }
  789. END;
  790. {--TRect--------------------------------------------------------------------}
  791. { Union -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  792. {---------------------------------------------------------------------------}
  793. PROCEDURE TRect.Union (R: TRect);
  794. BEGIN
  795. If (R.A.X < A.X) Then A.X := R.A.X; { Take if smaller }
  796. If (R.A.Y < A.Y) Then A.Y := R.A.Y; { Take if smaller }
  797. If (R.B.X > B.X) Then B.X := R.B.X; { Take if larger }
  798. If (R.B.Y > B.Y) Then B.Y := R.B.Y; { Take if larger }
  799. END;
  800. {--TRect--------------------------------------------------------------------}
  801. { Intersect -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  802. {---------------------------------------------------------------------------}
  803. PROCEDURE TRect.Intersect (R: TRect);
  804. BEGIN
  805. If (R.A.X > A.X) Then A.X := R.A.X; { Take if larger }
  806. If (R.A.Y > A.Y) Then A.Y := R.A.Y; { Take if larger }
  807. If (R.B.X < B.X) Then B.X := R.B.X; { Take if smaller }
  808. If (R.B.Y < B.Y) Then B.Y := R.B.Y; { Take if smaller }
  809. CheckEmpty(Self); { Check if empty }
  810. END;
  811. {--TRect--------------------------------------------------------------------}
  812. { Move -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  813. {---------------------------------------------------------------------------}
  814. PROCEDURE TRect.Move (ADX, ADY: Sw_Integer);
  815. BEGIN
  816. Inc(A.X, ADX); { Adjust A.X }
  817. Inc(A.Y, ADY); { Adjust A.Y }
  818. Inc(B.X, ADX); { Adjust B.X }
  819. Inc(B.Y, ADY); { Adjust B.Y }
  820. END;
  821. {--TRect--------------------------------------------------------------------}
  822. { Grow -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  823. {---------------------------------------------------------------------------}
  824. PROCEDURE TRect.Grow (ADX, ADY: Sw_Integer);
  825. BEGIN
  826. Dec(A.X, ADX); { Adjust A.X }
  827. Dec(A.Y, ADY); { Adjust A.Y }
  828. Inc(B.X, ADX); { Adjust B.X }
  829. Inc(B.Y, ADY); { Adjust B.Y }
  830. CheckEmpty(Self); { Check if empty }
  831. END;
  832. {--TRect--------------------------------------------------------------------}
  833. { Assign -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  834. {---------------------------------------------------------------------------}
  835. PROCEDURE TRect.Assign (XA, YA, XB, YB: Sw_Integer);
  836. BEGIN
  837. A.X := XA; { Hold A.X value }
  838. A.Y := YA; { Hold A.Y value }
  839. B.X := XB; { Hold B.X value }
  840. B.Y := YB; { Hold B.Y value }
  841. END;
  842. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  843. { TObject OBJECT METHODS }
  844. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  845. TYPE
  846. DummyObject = OBJECT (TObject) { Internal object }
  847. Data: RECORD END; { Helps size VMT link }
  848. END;
  849. { ******************************* REMARK ****************************** }
  850. { I Prefer this code because it self sizes VMT link rather than using a }
  851. { fixed record structure thus it should work on all compilers without a }
  852. { specific record to match each compiler. }
  853. { ****************************** END REMARK *** Leon de Boer, 10May96 * }
  854. {--TObject------------------------------------------------------------------}
  855. { Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  856. {---------------------------------------------------------------------------}
  857. CONSTRUCTOR TObject.Init;
  858. VAR LinkSize: LongInt; Dummy: DummyObject;
  859. BEGIN
  860. LinkSize := Pbyte(@Dummy.Data)-Pbyte(@Dummy); { Calc VMT link size }
  861. FillChar((Pbyte(@Self)+LinkSize)^,
  862. SizeOf(Self)-LinkSize, #0); { Clear data fields }
  863. END;
  864. {--TObject------------------------------------------------------------------}
  865. { Free -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  866. {---------------------------------------------------------------------------}
  867. PROCEDURE TObject.Free;
  868. BEGIN
  869. Dispose(PObject(@Self), Done); { Dispose of self }
  870. END;
  871. {--TObject------------------------------------------------------------------}
  872. { Is_Object -> Platforms DOS/DPMI/WIN/OS2 - Checked 5Mar00 DM }
  873. {---------------------------------------------------------------------------}
  874. FUNCTION TObject.Is_Object(P:Pointer):Boolean;
  875. TYPE
  876. PVMT=^VMT;
  877. PPVMT=^PVMT;
  878. VMT=RECORD
  879. Size,NegSize:SizeInt;
  880. ParentLink:PPVMT;
  881. END;
  882. VAR SP:PPVMT; Q:PVMT;
  883. BEGIN
  884. SP:=PPVMT(@SELF);
  885. Q:=SP^;
  886. Is_Object:=False;
  887. While Q<>Nil Do Begin
  888. IF Q=P THEN Begin
  889. Is_Object:=True;
  890. Break;
  891. End;
  892. IF Q^.Parentlink<>Nil THEN
  893. Q:=Q^.Parentlink^
  894. ELSE
  895. Q:=Nil;
  896. End;
  897. END;
  898. {--TObject------------------------------------------------------------------}
  899. { Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  900. {---------------------------------------------------------------------------}
  901. DESTRUCTOR TObject.Done;
  902. BEGIN { Abstract method }
  903. END;
  904. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  905. { TStream OBJECT METHODS }
  906. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  907. CONSTRUCTOR TStream.Init;
  908. BEGIN
  909. Status := StOK;
  910. ErrorInfo := 0;
  911. StreamSize := 0;
  912. Position := 0;
  913. TPCompatible := DefaultTPCompatible;
  914. END;
  915. {--TStream------------------------------------------------------------------}
  916. { Get -> Platforms DOS/DPMI/WIN/OS2 - Checked 02Sep97 LdB }
  917. {---------------------------------------------------------------------------}
  918. FUNCTION TStream.Get: PObject;
  919. VAR ObjType: Sw_Word; P: PStreamRec; ObjTypeWord: Word;
  920. BEGIN
  921. If TPCompatible Then Begin
  922. { Read 16-bit word for TP compatibility. }
  923. Read(ObjTypeWord, SizeOf(ObjTypeWord));
  924. ObjType := ObjTypeWord
  925. End
  926. else
  927. Read(ObjType, SizeOf(ObjType)); { Read object type }
  928. If (ObjType<>0) Then Begin { Object registered }
  929. P := StreamTypes; { Current reg list }
  930. While (P <> Nil) AND (P^.ObjType <> ObjType) { Find object type OR }
  931. Do P := P^.Next; { Find end of chain }
  932. If (P=Nil) Then Begin { Not registered }
  933. Error(stGetError, ObjType); { Obj not registered }
  934. Get := Nil; { Return nil pointer }
  935. End Else
  936. Get :=PObject(
  937. CallPointerConstructor(P^.Load,Nil,P^.VMTLink, @Self)) { Call constructor }
  938. End Else Get := Nil; { Return nil pointer }
  939. END;
  940. {--TStream------------------------------------------------------------------}
  941. { StrRead -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  942. {---------------------------------------------------------------------------}
  943. FUNCTION TStream.StrRead: PChar;
  944. VAR L: Word; P: PChar;
  945. BEGIN
  946. Read(L, SizeOf(L)); { Read length }
  947. If (L = 0) Then StrRead := Nil Else Begin { Check for empty }
  948. GetMem(P, L + 1); { Allocate memory }
  949. If (P <> Nil) Then Begin { Check allocate okay }
  950. Read(P[0], L); { Read the data }
  951. P[L] := #0; { Terminate with #0 }
  952. End;
  953. StrRead := P; { Return PChar }
  954. End;
  955. END;
  956. {--TStream------------------------------------------------------------------}
  957. { ReadStr -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  958. {---------------------------------------------------------------------------}
  959. FUNCTION TStream.ReadStr: PString;
  960. VAR L: Byte; P: PString;
  961. BEGIN
  962. Read(L, 1); { Read string length }
  963. If (L > 0) Then Begin
  964. GetMem(P, L + 1); { Allocate memory }
  965. If (P <> Nil) Then Begin { Check allocate okay }
  966. P^[0] := Char(L); { Hold length }
  967. Read(P^[1], L); { Read string data }
  968. End;
  969. ReadStr := P; { Return string ptr }
  970. End Else ReadStr := Nil;
  971. END;
  972. {--TStream------------------------------------------------------------------}
  973. { GetPos -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  974. {---------------------------------------------------------------------------}
  975. FUNCTION TStream.GetPos: LongInt;
  976. BEGIN
  977. If (Status=stOk) Then GetPos := Position { Return position }
  978. Else GetPos := -1; { Stream in error }
  979. END;
  980. {--TStream------------------------------------------------------------------}
  981. { GetSize -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  982. {---------------------------------------------------------------------------}
  983. FUNCTION TStream.GetSize: LongInt;
  984. BEGIN
  985. If (Status=stOk) Then GetSize := StreamSize { Return stream size }
  986. Else GetSize := -1; { Stream in error }
  987. END;
  988. {--TStream------------------------------------------------------------------}
  989. { Close -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  990. {---------------------------------------------------------------------------}
  991. PROCEDURE TStream.Close;
  992. BEGIN { Abstract method }
  993. END;
  994. {--TStream------------------------------------------------------------------}
  995. { Reset -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  996. {---------------------------------------------------------------------------}
  997. PROCEDURE TStream.Reset;
  998. BEGIN
  999. Status := stOK; { Clear status }
  1000. ErrorInfo := 0; { Clear error info }
  1001. END;
  1002. {--TStream------------------------------------------------------------------}
  1003. { Flush -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  1004. {---------------------------------------------------------------------------}
  1005. PROCEDURE TStream.Flush;
  1006. BEGIN { Abstract method }
  1007. END;
  1008. {--TStream------------------------------------------------------------------}
  1009. { Truncate -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  1010. {---------------------------------------------------------------------------}
  1011. PROCEDURE TStream.Truncate;
  1012. BEGIN
  1013. Abstract; { Abstract error }
  1014. END;
  1015. {--TStream------------------------------------------------------------------}
  1016. { Put -> Platforms DOS/DPMI/WIN/OS2 - Checked 02Sep97 LdB }
  1017. {---------------------------------------------------------------------------}
  1018. PROCEDURE TStream.Put (P: PObject);
  1019. VAR ObjType: Sw_Word; Link: pointer; Q: PStreamRec; VmtPtr: ^pointer;
  1020. ObjTypeWord: Word;
  1021. BEGIN
  1022. VmtPtr := Pointer(P); { Xfer object to ptr }
  1023. if assigned(vmtptr) then
  1024. Link := VmtPtr^ { VMT link }
  1025. else
  1026. Link:=nil;
  1027. ObjType := 0; { Set objtype to zero }
  1028. If (P<>Nil) AND (Link<>Nil) Then Begin { We have a VMT link }
  1029. Q := StreamTypes; { Current reg list }
  1030. While (Q <> Nil) AND (Q^.VMTLink <> Link) { Find link match OR }
  1031. Do Q := Q^.Next; { Find end of chain }
  1032. If (Q=Nil) Then Begin { End of chain found }
  1033. Error(stPutError, 0); { Not registered error }
  1034. Exit; { Now exit }
  1035. End Else ObjType := Q^.ObjType; { Update object type }
  1036. End;
  1037. If TPCompatible Then Begin
  1038. ObjTypeWord := word(ObjType);
  1039. Write(ObjTypeWord, SizeOf(ObjTypeWord))
  1040. end
  1041. else
  1042. Write(ObjType, SizeOf(ObjType)); { Write object type }
  1043. If (ObjType<>0) Then { Registered object }
  1044. CallPointerMethod(Q^.Store, P, @Self);
  1045. END;
  1046. {--TStream------------------------------------------------------------------}
  1047. { Seek -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  1048. {---------------------------------------------------------------------------}
  1049. PROCEDURE TStream.Seek (Pos: LongInt);
  1050. BEGIN
  1051. If (Status = stOk) Then Begin { Check status }
  1052. If (Pos < 0) Then Pos := 0; { Remove negatives }
  1053. If (Pos <= StreamSize) Then Position := Pos { If valid set pos }
  1054. Else Error(stSeekError, Pos); { Position error }
  1055. End;
  1056. END;
  1057. {--TStream------------------------------------------------------------------}
  1058. { StrWrite -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  1059. {---------------------------------------------------------------------------}
  1060. PROCEDURE TStream.StrWrite (P: PChar);
  1061. VAR L: Word; Q: PByteArray;
  1062. BEGIN
  1063. L := 0; { Preset zero size }
  1064. Q := PByteArray(P); { Transfer type }
  1065. If (Q <> Nil) Then While (Q^[L] <> 0) Do Inc(L); { PChar length }
  1066. Write(L, SizeOf(L)); { Store length }
  1067. If (P <> Nil) Then Write(P[0], L); { Write data }
  1068. END;
  1069. {--TStream------------------------------------------------------------------}
  1070. { WriteStr -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  1071. {---------------------------------------------------------------------------}
  1072. PROCEDURE TStream.WriteStr (P: PString);
  1073. CONST Empty: String[1] = '';
  1074. BEGIN
  1075. If (P <> Nil) Then Write(P^, Length(P^) + 1) { Write string }
  1076. Else Write(Empty, 1); { Write empty string }
  1077. END;
  1078. {--TStream------------------------------------------------------------------}
  1079. { Open -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  1080. {---------------------------------------------------------------------------}
  1081. PROCEDURE TStream.Open (OpenMode: Word);
  1082. BEGIN { Abstract method }
  1083. END;
  1084. {--TStream------------------------------------------------------------------}
  1085. { Error -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  1086. {---------------------------------------------------------------------------}
  1087. PROCEDURE TStream.Error (Code, Info: Integer);
  1088. TYPE TErrorProc = Procedure(Var S: TStream);
  1089. BEGIN
  1090. Status := Code; { Hold error code }
  1091. ErrorInfo := Info; { Hold error info }
  1092. If (StreamError <> Nil) Then
  1093. TErrorProc(StreamError)(Self); { Call error ptr }
  1094. END;
  1095. {--TStream------------------------------------------------------------------}
  1096. { Read -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  1097. {---------------------------------------------------------------------------}
  1098. PROCEDURE TStream.Read (Var Buf; Count: Longint);
  1099. BEGIN
  1100. Abstract; { Abstract error }
  1101. END;
  1102. {--TStream------------------------------------------------------------------}
  1103. { Write -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  1104. {---------------------------------------------------------------------------}
  1105. PROCEDURE TStream.Write (Var Buf; Count: Longint);
  1106. BEGIN
  1107. Abstract; { Abstract error }
  1108. END;
  1109. {--TStream------------------------------------------------------------------}
  1110. { CopyFrom -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB }
  1111. {---------------------------------------------------------------------------}
  1112. PROCEDURE TStream.CopyFrom (Var S: TStream; Count: Longint);
  1113. VAR W: Word; Buffer: Array[0..1023] of Byte;
  1114. BEGIN
  1115. While (Count > 0) Do Begin
  1116. If (Count > SizeOf(Buffer)) Then { To much data }
  1117. W := SizeOf(Buffer) Else W := Count; { Size to transfer }
  1118. S.Read(Buffer, W); { Read from stream }
  1119. Write(Buffer, W); { Write to stream }
  1120. Dec(Count, W); { Dec write count }
  1121. End;
  1122. END;
  1123. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  1124. { TDosStream OBJECT METHODS }
  1125. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  1126. {$PUSH}
  1127. {$I-}
  1128. {--TDosStream---------------------------------------------------------------}
  1129. { Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
  1130. {---------------------------------------------------------------------------}
  1131. CONSTRUCTOR TDosStream.Init (FileName: FNameStr; Mode: Word);
  1132. VAR OldFileMode : Byte;
  1133. DosStreamError : Word;
  1134. BEGIN
  1135. Inherited Init; { Call ancestor }
  1136. FileName := FileName+#0; { Make asciiz }
  1137. Move(FileName[1], FName, Length(FileName)); { Create asciiz name }
  1138. Handle := InvalidHandle;
  1139. Assign(FileInfo,FileName);
  1140. { Handle the mode }
  1141. if Mode =stCreate then
  1142. Begin
  1143. Rewrite(FileInfo,1);
  1144. end
  1145. else
  1146. Begin
  1147. OldFileMode := FileMode;
  1148. { Keep sharing modes! }
  1149. FileMode := Mode and $FF;
  1150. System.Reset(FileInfo,1);
  1151. FileMode := OldFileMode;
  1152. { To use the correct mode we must reclose the file
  1153. and open it again
  1154. }
  1155. end;
  1156. Handle := FileRec(FileInfo).Handle; { Set handle value }
  1157. DosStreamError := IOResult;
  1158. If DosStreamError = 0 then
  1159. Begin
  1160. StreamSize := System.FileSize(FileInfo);
  1161. end;
  1162. If DosStreamError = 0 then
  1163. DosStreamError := IOResult;
  1164. If (DosStreamError <> 0) Then
  1165. Error(stInitError, DosStreamError) { Call stream error }
  1166. else
  1167. Status := StOK;
  1168. END;
  1169. {--TDosStream---------------------------------------------------------------}
  1170. { Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
  1171. {---------------------------------------------------------------------------}
  1172. DESTRUCTOR TDosStream.Done;
  1173. var
  1174. DosStreamError : Word;
  1175. BEGIN
  1176. if Handle <> InvalidHandle then
  1177. Begin
  1178. System.Close(FileInfo);
  1179. DosStreamError := IOResult;
  1180. If DosStreamError = 0 then
  1181. Status := stOk
  1182. else
  1183. Error(stError, DosStreamError);
  1184. end;
  1185. Position := 0; { Zero the position }
  1186. Handle := InvalidHandle;
  1187. Inherited Done; { Call ancestor }
  1188. END;
  1189. {--TDosStream---------------------------------------------------------------}
  1190. { Close -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
  1191. {---------------------------------------------------------------------------}
  1192. PROCEDURE TDosStream.Close;
  1193. var
  1194. DosStreamError : Word;
  1195. BEGIN
  1196. if Handle <> InvalidHandle then { Is file closed ? }
  1197. Begin
  1198. System.Close(FileInfo); { Close file }
  1199. DosStreamError := IOResult; { Check for error }
  1200. If DosStreamError = 0 then
  1201. Status := stOk
  1202. else
  1203. Error(stError, DosStreamError); { Call error routine }
  1204. end;
  1205. Position := 0; { Zero the position }
  1206. Handle := InvalidHandle; { Handle invalid }
  1207. END;
  1208. {--TDosStream---------------------------------------------------------------}
  1209. { Truncate -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
  1210. {---------------------------------------------------------------------------}
  1211. PROCEDURE TDosStream.Truncate;
  1212. var
  1213. DosStreamError : Word;
  1214. BEGIN
  1215. If Status = stOk then
  1216. Begin
  1217. System.Truncate(FileInfo);
  1218. DosStreamError := IOResult;
  1219. If DosStreamError = 0 then
  1220. { Status is already = stOK }
  1221. StreamSize := Position
  1222. else
  1223. Error(stError, DosStreamError);
  1224. end;
  1225. END;
  1226. {--TDosStream---------------------------------------------------------------}
  1227. { Seek -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
  1228. {---------------------------------------------------------------------------}
  1229. PROCEDURE TDosStream.Seek (Pos: Longint);
  1230. var
  1231. DosStreamError : Word;
  1232. BEGIN
  1233. If (Status=stOk) Then
  1234. Begin { Check status okay }
  1235. If (Pos < 0) Then
  1236. Pos := 0; { Negatives removed }
  1237. System.Seek(FileInfo, Pos);
  1238. DosStreamError := IOResult;
  1239. if DosStreamError <> 0 then
  1240. Error(stSeekError, DosStreamError){ Specific seek error }
  1241. Else Position := Pos; { Adjust position }
  1242. { Status is already = stOK }
  1243. End;
  1244. END;
  1245. {--TDosStream---------------------------------------------------------------}
  1246. { Open -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
  1247. {---------------------------------------------------------------------------}
  1248. PROCEDURE TDosStream.Open (OpenMode: Word);
  1249. VAR OldFileMode : Byte;
  1250. DosStreamError : Word;
  1251. BEGIN
  1252. If (Status=stOk) Then
  1253. Begin { Check status okay }
  1254. If (Handle = InvalidHandle) Then
  1255. Begin { File not open }
  1256. Assign(FileInfo,@FName);
  1257. { Handle the mode }
  1258. if OpenMode =stCreate then
  1259. Begin
  1260. System.Rewrite(FileInfo,1);
  1261. end
  1262. else
  1263. Begin
  1264. OldFileMode := FileMode;
  1265. FileMode := OpenMode and 3;
  1266. System.Reset(FileInfo,1);
  1267. FileMode := OldFileMode;
  1268. { To use the correct mode we must reclose the file
  1269. and open it again
  1270. }
  1271. end;
  1272. Handle := FileRec(FileInfo).Handle; { Set handle value }
  1273. DosStreamError := IOResult;
  1274. If DosStreamError = 0 then
  1275. StreamSize := System.FileSize(FileInfo);
  1276. If DosStreamError = 0 then
  1277. DosStreamError := IOResult;
  1278. If (DosStreamError <> 0) Then
  1279. Error(stOpenError, DosStreamError) { Call stream error }
  1280. else
  1281. Status := StOK;
  1282. Position := 0;
  1283. end
  1284. Else
  1285. Error(stOpenError, 104); { File already open }
  1286. End;
  1287. END;
  1288. {--TDosStream---------------------------------------------------------------}
  1289. { Read -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
  1290. {---------------------------------------------------------------------------}
  1291. PROCEDURE TDosStream.Read (Var Buf; Count: Longint);
  1292. VAR BytesMoved: Longint;
  1293. DosStreamError : Word;
  1294. BEGIN
  1295. If Status = StOK then
  1296. Begin
  1297. If (Position + Count > StreamSize) Then { Insufficient data }
  1298. Error(stReadError, 0); { Read beyond end!!! }
  1299. If (Handle = InvalidHandle) Then
  1300. Error(stReadError, 103); { File not open }
  1301. BlockRead(FileInfo, Buf, Count, BytesMoved); { Read from file }
  1302. DosStreamError := IOResult;
  1303. If ((DosStreamError<>0) OR (BytesMoved<>Count)) Then
  1304. Begin { Error was detected }
  1305. BytesMoved := 0; { Clear bytes moved }
  1306. If (DosStreamError <> 0) Then
  1307. Error(stReadError, DosStreamError) { Specific read error }
  1308. Else
  1309. Error(stReadError, 0); { Non specific error }
  1310. End;
  1311. Inc(Position, BytesMoved); { Adjust position }
  1312. End;
  1313. { If there was already an error, or an error was just
  1314. generated, fill the vuffer with NULL
  1315. }
  1316. If Status <> StOK then
  1317. FillChar(Buf, Count, #0); { Error clear buffer }
  1318. END;
  1319. {--TDosStream---------------------------------------------------------------}
  1320. { Write -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB }
  1321. {---------------------------------------------------------------------------}
  1322. PROCEDURE TDosStream.Write (Var Buf; Count: Longint);
  1323. VAR BytesMoved: Longint;
  1324. DosStreamError : Word;
  1325. BEGIN
  1326. { If status is not OK, simply exit }
  1327. if Status <> StOK then
  1328. exit;
  1329. If (Handle = InvalidHandle) Then
  1330. Error(stWriteError, 103); { File not open }
  1331. BlockWrite(FileInfo, Buf, Count, BytesMoved); { Write to file }
  1332. DosStreamError := IOResult;
  1333. If ((DosStreamError<>0) OR (BytesMoved<>Count)) Then
  1334. Begin { Error was detected }
  1335. BytesMoved := 0; { Clear bytes moved }
  1336. If (DosStreamError<>0) Then
  1337. Error(stWriteError, DOSStreamError) { Specific write error }
  1338. Else
  1339. Error(stWriteError, 0); { Non specific error }
  1340. End;
  1341. Inc(Position, BytesMoved); { Adjust position }
  1342. If (Position > StreamSize) Then { File expanded }
  1343. StreamSize := Position; { Adjust stream size }
  1344. END;
  1345. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  1346. { TBufStream OBJECT METHODS }
  1347. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  1348. {--TBufStream---------------------------------------------------------------}
  1349. { Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB }
  1350. {---------------------------------------------------------------------------}
  1351. CONSTRUCTOR TBufStream.Init (FileName: FNameStr; Mode, Size: Word);
  1352. BEGIN
  1353. Inherited Init(FileName, Mode); { Call ancestor }
  1354. BufSize := Size; { Hold buffer size }
  1355. If (Size<>0) Then GetMem(Buffer, Size); { Allocate buffer }
  1356. If (Buffer=Nil) Then Error(stInitError, 0); { Buffer allocate fail }
  1357. END;
  1358. {--TBufStream---------------------------------------------------------------}
  1359. { Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB }
  1360. {---------------------------------------------------------------------------}
  1361. DESTRUCTOR TBufStream.Done;
  1362. BEGIN
  1363. Flush; { Flush the file }
  1364. Inherited Done; { Call ancestor }
  1365. If (Buffer<>Nil) Then FreeMem(Buffer, BufSize); { Release buffer }
  1366. END;
  1367. {--TBufStream---------------------------------------------------------------}
  1368. { Close -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB }
  1369. {---------------------------------------------------------------------------}
  1370. PROCEDURE TBufStream.Close;
  1371. BEGIN
  1372. Flush; { Flush the buffer }
  1373. Inherited Close; { Call ancestor }
  1374. END;
  1375. {--TBufStream---------------------------------------------------------------}
  1376. { Flush -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB }
  1377. {---------------------------------------------------------------------------}
  1378. PROCEDURE TBufStream.Flush;
  1379. VAR W: Longint;
  1380. DosStreamError : Word;
  1381. BEGIN
  1382. If Status <> StOK then
  1383. exit;
  1384. If (LastMode=2) AND (BufPtr<>0) Then Begin { Must update file }
  1385. If (Handle = InvalidHandle) Then DosStreamError := 103 { File is not open }
  1386. Else
  1387. Begin
  1388. BlockWrite(FileInfo, Buffer^,BufPtr, W); { Write to file }
  1389. DosStreamError := IOResult;
  1390. End;
  1391. If (DosStreamError<>0) OR (W<>BufPtr) Then { We have an error }
  1392. If (DosStreamError=0) Then Error(stWriteError, 0){ Unknown write error }
  1393. Else Error(stError, DosStreamError); { Specific write error }
  1394. End;
  1395. BufPtr := 0; { Reset buffer ptr }
  1396. BufEnd := 0; { Reset buffer end }
  1397. END;
  1398. {--TBufStream---------------------------------------------------------------}
  1399. { Truncate -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB }
  1400. {---------------------------------------------------------------------------}
  1401. PROCEDURE TBufStream.Truncate;
  1402. BEGIN
  1403. Flush; { Flush buffer }
  1404. Inherited Truncate; { Truncate file }
  1405. END;
  1406. {--TBufStream---------------------------------------------------------------}
  1407. { Seek -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB }
  1408. {---------------------------------------------------------------------------}
  1409. PROCEDURE TBufStream.Seek (Pos: LongInt);
  1410. BEGIN
  1411. If (Status=stOk) Then Begin { Check status okay }
  1412. If (Position<>Pos) Then Begin { Move required }
  1413. Flush; { Flush the buffer }
  1414. Inherited Seek(Pos); { Call ancestor }
  1415. End;
  1416. End;
  1417. END;
  1418. {--TBufStream---------------------------------------------------------------}
  1419. { Open -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB }
  1420. {---------------------------------------------------------------------------}
  1421. PROCEDURE TBufStream.Open (OpenMode: Word);
  1422. BEGIN
  1423. If (Status=stOk) Then Begin { Check status okay }
  1424. BufPtr := 0; { Clear buffer start }
  1425. BufEnd := 0; { Clear buffer end }
  1426. Inherited Open(OpenMode); { Call ancestor }
  1427. End;
  1428. END;
  1429. {--TBufStream---------------------------------------------------------------}
  1430. { Read -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB }
  1431. {---------------------------------------------------------------------------}
  1432. PROCEDURE TBufStream.Read (Var Buf; Count: Longint);
  1433. VAR W, Bw: Longint; P: PByte;
  1434. DosStreamError : Word;
  1435. BEGIN
  1436. If Status <> StOk then
  1437. begin
  1438. FillChar(Buf, Count, #0); { Error clear buffer }
  1439. exit;
  1440. end;
  1441. If (Position + Count > StreamSize) Then { Read pas stream end }
  1442. Error(stReadError, 0); { Call stream error }
  1443. If (Handle = InvalidHandle) Then Error(stReadError, 103); { File not open }
  1444. P := @Buf; { Transfer address }
  1445. If (LastMode=2) Then Flush; { Flush write buffer }
  1446. LastMode := 1; { Now set read mode }
  1447. While (Count>0) AND (Status=stOk) Do Begin { Check status & count }
  1448. If (BufPtr=BufEnd) Then Begin { Buffer is empty }
  1449. If (Position + BufSize > StreamSize) Then
  1450. Bw := StreamSize - Position { Amount of file left }
  1451. Else Bw := BufSize; { Full buffer size }
  1452. BlockRead(FileInfo, Buffer^, Bw, W);
  1453. DosStreamError := IOResult; { Read from file }
  1454. If ((DosStreamError<>0) OR (Bw<>W)) Then Begin { Error was detected }
  1455. If (DosStreamError<>0) Then
  1456. Error(stReadError, DosStreamError) { Specific read error }
  1457. Else Error(stReadError, 0); { Non specific error }
  1458. End Else Begin
  1459. BufPtr := 0; { Reset BufPtr }
  1460. BufEnd := W; { End of buffer }
  1461. End;
  1462. End;
  1463. If (Status=stOk) Then Begin { Status still okay }
  1464. W := BufEnd - BufPtr; { Space in buffer }
  1465. If (Count < W) Then W := Count; { Set transfer size }
  1466. Move(Buffer^[BufPtr], P^, W); { Data from buffer }
  1467. Dec(Count, W); { Reduce count }
  1468. Inc(BufPtr, W); { Advance buffer ptr }
  1469. Inc(P, W); { Transfer address }
  1470. Inc(Position, W); { Advance position }
  1471. End;
  1472. End;
  1473. If (Status<>stOk) AND (Count>0) Then
  1474. FillChar(P^, Count, #0); { Error clear buffer }
  1475. END;
  1476. {--TBufStream---------------------------------------------------------------}
  1477. { Write -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB }
  1478. {---------------------------------------------------------------------------}
  1479. PROCEDURE TBufStream.Write (Var Buf; Count: Longint);
  1480. VAR W: Longint;
  1481. P: PByte;
  1482. DosStreamError : Word;
  1483. BEGIN
  1484. if Status <> StOK then exit; { Exit if error }
  1485. If (Handle = InvalidHandle) Then Error(stWriteError, 103); { File not open }
  1486. If (LastMode=1) Then Flush; { Flush read buffer }
  1487. LastMode := 2; { Now set write mode }
  1488. P := @Buf; { Transfer address }
  1489. While (Count>0) AND (Status=stOk) Do Begin { Check status & count }
  1490. If (BufPtr=BufSize) Then Begin { Buffer is full }
  1491. BlockWrite(FileInfo, Buffer^, BufSize,W); { Write to file }
  1492. DosStreamError := IOResult;
  1493. If (DosStreamError<>0) OR (W<>BufSize) Then { We have an error }
  1494. If (DosStreamError=0) Then Error(stWriteError, 0) { Unknown write error }
  1495. Else Error(stError, DosStreamError); { Specific write error }
  1496. BufPtr := 0; { Reset BufPtr }
  1497. End;
  1498. If (Status=stOk) Then Begin { Status still okay }
  1499. W := BufSize - BufPtr; { Space in buffer }
  1500. If (Count < W) Then W := Count; { Transfer size }
  1501. Move(P^, Buffer^[BufPtr], W); { Data to buffer }
  1502. Dec(Count, W); { Reduce count }
  1503. Inc(BufPtr, W); { Advance buffer ptr }
  1504. Inc(P,W); { Transfer address }
  1505. Inc(Position, W); { Advance position }
  1506. If (Position > StreamSize) Then { File has expanded }
  1507. StreamSize := Position; { Update new size }
  1508. End;
  1509. End;
  1510. END;
  1511. {$POP} //{$i-} for TDosStream, TBufStream
  1512. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  1513. { TMemoryStream OBJECT METHODS }
  1514. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  1515. {--TMemoryStream------------------------------------------------------------}
  1516. { Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB }
  1517. {---------------------------------------------------------------------------}
  1518. CONSTRUCTOR TMemoryStream.Init (ALimit: LongInt; ABlockSize: Word);
  1519. VAR W: Word;
  1520. BEGIN
  1521. Inherited Init; { Call ancestor }
  1522. If (ABlockSize=0) Then BlkSize := 8192 Else { Default blocksize }
  1523. BlkSize := ABlockSize; { Set blocksize }
  1524. If (ALimit = 0) Then W := 1 Else { At least 1 block }
  1525. W := (ALimit + BlkSize - 1) DIV BlkSize; { Blocks needed }
  1526. If NOT ChangeListSize(W) Then { Try allocate blocks }
  1527. Error(stInitError, 0); { Initialize error }
  1528. END;
  1529. {--TMemoryStream------------------------------------------------------------}
  1530. { Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB }
  1531. {---------------------------------------------------------------------------}
  1532. DESTRUCTOR TMemoryStream.Done;
  1533. BEGIN
  1534. ChangeListSize(0); { Release all memory }
  1535. Inherited Done; { Call ancestor }
  1536. END;
  1537. {--TMemoryStream------------------------------------------------------------}
  1538. { Truncate -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB }
  1539. {---------------------------------------------------------------------------}
  1540. PROCEDURE TMemoryStream.Truncate;
  1541. VAR W: Word;
  1542. BEGIN
  1543. If (Status=stOk) Then Begin { Check status okay }
  1544. If (Position = 0) Then W := 1 Else { At least one block }
  1545. W := (Position + BlkSize - 1) DIV BlkSize; { Blocks needed }
  1546. If ChangeListSize(W) Then StreamSize := Position { Set stream size }
  1547. Else Error(stError, 0); { Error truncating }
  1548. End;
  1549. END;
  1550. {--TMemoryStream------------------------------------------------------------}
  1551. { Read -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB }
  1552. {---------------------------------------------------------------------------}
  1553. PROCEDURE TMemoryStream.Read (Var Buf; Count: Longint);
  1554. VAR W, CurBlock, BlockPos: Word; Li: LongInt; P, Q: PByte;
  1555. BEGIN
  1556. If (Position + Count > StreamSize) Then { Insufficient data }
  1557. Error(stReadError, 0); { Read beyond end!!! }
  1558. P := @Buf; { Transfer address }
  1559. While (Count>0) AND (Status=stOk) Do Begin { Check status & count }
  1560. CurBlock := Position DIV BlkSize; { Current block }
  1561. { * REMARK * - Do not shorten this, result can be > 64K }
  1562. Li := CurBlock; { Transfer current block }
  1563. Li := Li * BlkSize; { Current position }
  1564. { * REMARK END * - Leon de Boer }
  1565. BlockPos := Position - Li; { Current position }
  1566. W := BlkSize - BlockPos; { Current block space }
  1567. If (W > Count) Then W := Count; { Adjust read size }
  1568. Q := BlkList^[CurBlock] + BlockPos; { Calc pointer }
  1569. Move(Q^, P^, W); { Move data to buffer }
  1570. Inc(Position, W); { Adjust position }
  1571. Inc(P, W);
  1572. Dec(Count, W); { Adjust count left }
  1573. End;
  1574. If (Count<>0) Then FillChar(P^, Count, #0); { Error clear buffer }
  1575. END;
  1576. {--TMemoryStream------------------------------------------------------------}
  1577. { Write -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB }
  1578. {---------------------------------------------------------------------------}
  1579. PROCEDURE TMemoryStream.Write (Var Buf; Count: Longint);
  1580. VAR
  1581. W, CurBlock, BlockPos: Word;
  1582. Li: LongInt;
  1583. P, Q: PByte;
  1584. BEGIN
  1585. If (Position + Count > MemSize) Then Begin { Expansion needed }
  1586. If (Position + Count = 0) Then W := 1 Else { At least 1 block }
  1587. W := (Position+Count+BlkSize-1) DIV BlkSize; { Blocks needed }
  1588. If NOT ChangeListSize(W) Then
  1589. Error(stWriteError, 0); { Expansion failed!!! }
  1590. End;
  1591. P := @Buf; { Transfer address }
  1592. While (Count>0) AND (Status=stOk) Do Begin { Check status & count }
  1593. CurBlock := Position DIV BlkSize; { Current segment }
  1594. { * REMARK * - Do not shorten this, result can be > 64K }
  1595. Li := CurBlock; { Transfer current block }
  1596. Li := Li * BlkSize; { Current position }
  1597. { * REMARK END * - Leon de Boer }
  1598. BlockPos := Position - Li; { Current position }
  1599. W := BlkSize - BlockPos; { Current block space }
  1600. If (W > Count) Then W := Count; { Adjust write size }
  1601. Q := BlkList^[CurBlock] + BlockPos; { Calc pointer }
  1602. Move(P^, Q^, W); { Transfer data }
  1603. Inc(Position, W); { Adjust position }
  1604. Inc(P, W);
  1605. Dec(Count, W); { Adjust count left }
  1606. If (Position > StreamSize) Then { File expanded }
  1607. StreamSize := Position; { Adjust stream size }
  1608. End;
  1609. END;
  1610. {***************************************************************************}
  1611. { TMemoryStream PRIVATE METHODS }
  1612. {***************************************************************************}
  1613. {--TMemoryStream------------------------------------------------------------}
  1614. { ChangeListSize -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB }
  1615. {---------------------------------------------------------------------------}
  1616. FUNCTION TMemoryStream.ChangeListSize (ALimit: Longint): Boolean;
  1617. VAR
  1618. W: Longint;
  1619. Li: LongInt;
  1620. P: PPointerArray;
  1621. BEGIN
  1622. If (ALimit <> BlkCount) Then Begin { Change is needed }
  1623. ChangeListSize := False; { Preset failure }
  1624. If (ALimit > MaxPtrs) Then Exit; { To many blocks req }
  1625. If (ALimit <> 0) Then Begin { Create segment list }
  1626. Li := ALimit * SizeOf(Pointer); { Block array size }
  1627. GetMem(P, Li); { Allocate memory }
  1628. FillChar(P^, Li, #0); { Clear the memory }
  1629. If (BlkCount <> 0) AND (BlkList <> Nil) Then { Current list valid }
  1630. If (BlkCount <= ALimit) Then Move(BlkList^,
  1631. P^, BlkCount * SizeOf(Pointer)) Else { Move whole old list }
  1632. Move(BlkList^, P^, Li); { Move partial list }
  1633. End Else P := Nil; { No new block list }
  1634. If (ALimit < BlkCount) Then { Shrink stream size }
  1635. For W := BlkCount-1 DownTo ALimit Do
  1636. FreeMem(BlkList^[W], BlkSize); { Release memory block }
  1637. If (P <> Nil) AND (ALimit > BlkCount) Then Begin { Expand stream size }
  1638. For W := BlkCount To ALimit-1 Do Begin
  1639. GetMem(P^[W], BlkSize); { Allocate memory }
  1640. End;
  1641. End;
  1642. If (BlkCount <> 0) AND (BlkList<>Nil) Then
  1643. FreeMem(BlkList, BlkCount * SizeOf(Pointer)); { Release old list }
  1644. BlkList := P; { Hold new block list }
  1645. BlkCount := ALimit; { Hold new count }
  1646. { * REMARK * - Do not shorten this, result can be > 64K }
  1647. MemSize := BlkCount; { Block count }
  1648. MemSize := MemSize * BlkSize; { Current position }
  1649. { * REMARK END * - Leon de Boer }
  1650. End;
  1651. ChangeListSize := True; { Successful }
  1652. END;
  1653. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  1654. { TCollection OBJECT METHODS }
  1655. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  1656. {--TCollection--------------------------------------------------------------}
  1657. { Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1658. {---------------------------------------------------------------------------}
  1659. CONSTRUCTOR TCollection.Init (ALimit, ADelta: Sw_Integer);
  1660. BEGIN
  1661. Inherited Init; { Call ancestor }
  1662. Delta := ADelta; { Set increment }
  1663. SetLimit(ALimit); { Set limit }
  1664. END;
  1665. {--TCollection--------------------------------------------------------------}
  1666. { Load -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1667. {---------------------------------------------------------------------------}
  1668. CONSTRUCTOR TCollection.Load (Var S: TStream);
  1669. VAR C, I: Sw_Integer;
  1670. BEGIN
  1671. If S.TPCompatible Then Begin
  1672. { I ignore endianness issues here. If endianness is different,
  1673. you can't expect binary compatible resources anyway. }
  1674. Count := 0; S.Read(Count, Sizeof(Word));
  1675. Limit := 0; S.Read(Limit, Sizeof(Word));
  1676. Delta := 0; S.Read(Delta, Sizeof(Word))
  1677. End
  1678. Else Begin
  1679. S.Read(Count, Sizeof(Count)); { Read count }
  1680. S.Read(Limit, Sizeof(Limit)); { Read limit }
  1681. S.Read(Delta, Sizeof(Delta)); { Read delta }
  1682. End;
  1683. Items := Nil; { Clear item pointer }
  1684. C := Count; { Hold count }
  1685. I := Limit; { Hold limit }
  1686. Count := 0; { Clear count }
  1687. Limit := 0; { Clear limit }
  1688. SetLimit(I); { Set requested limit }
  1689. Count := C; { Set count }
  1690. For I := 0 To C-1 Do AtPut(I, GetItem(S)); { Get each item }
  1691. END;
  1692. {--TCollection--------------------------------------------------------------}
  1693. { Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1694. {---------------------------------------------------------------------------}
  1695. DESTRUCTOR TCollection.Done;
  1696. BEGIN
  1697. FreeAll; { Free all items }
  1698. SetLimit(0); { Release all memory }
  1699. END;
  1700. {--TCollection--------------------------------------------------------------}
  1701. { At -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1702. {---------------------------------------------------------------------------}
  1703. FUNCTION TCollection.At (Index: Sw_Integer): Pointer;
  1704. BEGIN
  1705. If (Index < 0) OR (Index >= Count) Then Begin { Invalid index }
  1706. Error(coIndexError, Index); { Call error }
  1707. At := Nil; { Return nil }
  1708. End Else At := Items^[Index]; { Return item }
  1709. END;
  1710. {--TCollection--------------------------------------------------------------}
  1711. { IndexOf -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1712. {---------------------------------------------------------------------------}
  1713. FUNCTION TCollection.IndexOf (Item: Pointer): Sw_Integer;
  1714. VAR I: Sw_Integer;
  1715. BEGIN
  1716. If (Count>0) Then Begin { Count is positive }
  1717. For I := 0 To Count-1 Do { For each item }
  1718. If (Items^[I]=Item) Then Begin { Look for match }
  1719. IndexOf := I; { Return index }
  1720. Exit; { Now exit }
  1721. End;
  1722. End;
  1723. IndexOf := -1; { Return index }
  1724. END;
  1725. {--TCollection--------------------------------------------------------------}
  1726. { GetItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1727. {---------------------------------------------------------------------------}
  1728. FUNCTION TCollection.GetItem (Var S: TStream): Pointer;
  1729. BEGIN
  1730. GetItem := S.Get; { Item off stream }
  1731. END;
  1732. {--TCollection--------------------------------------------------------------}
  1733. { LastThat -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1734. {---------------------------------------------------------------------------}
  1735. {$PUSH}
  1736. {$W+}
  1737. FUNCTION TCollection.LastThat (Test: CodePointer): Pointer;
  1738. VAR I: LongInt;
  1739. BEGIN
  1740. For I := Count DownTo 1 Do
  1741. Begin { Down from last item }
  1742. IF Boolean(Byte(ptruint(CallPointerLocal(Test,
  1743. { On most systems, locals are accessed relative to base pointer,
  1744. but for MIPS cpu, they are accessed relative to stack pointer.
  1745. This needs adaptation for so low level routines,
  1746. like MethodPointerLocal and related objects unit functions. }
  1747. {$ifndef FPC_LOCALS_ARE_STACK_REG_RELATIVE}
  1748. get_caller_frame(get_frame,get_pc_addr)
  1749. {$else}
  1750. get_frame
  1751. {$endif}
  1752. ,Items^[I-1])))) THEN
  1753. Begin { Test each item }
  1754. LastThat := Items^[I-1]; { Return item }
  1755. Exit; { Now exit }
  1756. End;
  1757. End;
  1758. LastThat := Nil; { None passed test }
  1759. END;
  1760. {--TCollection--------------------------------------------------------------}
  1761. { FirstThat -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1762. {---------------------------------------------------------------------------}
  1763. FUNCTION TCollection.FirstThat (Test: CodePointer): Pointer;
  1764. VAR I: LongInt;
  1765. BEGIN
  1766. For I := 1 To Count Do Begin { Up from first item }
  1767. IF Boolean(Byte(ptruint(CallPointerLocal(Test,
  1768. { On most systems, locals are accessed relative to base pointer,
  1769. but for MIPS cpu, they are accessed relative to stack pointer.
  1770. This needs adaptation for so low level routines,
  1771. like MethodPointerLocal and related objects unit functions. }
  1772. {$ifndef FPC_LOCALS_ARE_STACK_REG_RELATIVE}
  1773. get_caller_frame(get_frame,get_pc_addr)
  1774. {$else}
  1775. get_frame
  1776. {$endif}
  1777. ,Items^[I-1])))) THEN
  1778. Begin { Test each item }
  1779. FirstThat := Items^[I-1]; { Return item }
  1780. Exit; { Now exit }
  1781. End;
  1782. End;
  1783. FirstThat := Nil; { None passed test }
  1784. END;
  1785. {$POP}
  1786. {--TCollection--------------------------------------------------------------}
  1787. { Pack -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1788. {---------------------------------------------------------------------------}
  1789. PROCEDURE TCollection.Pack;
  1790. VAR I, J: Sw_Integer;
  1791. BEGIN
  1792. I := 0; { Initialize dest }
  1793. J := 0; { Intialize test }
  1794. While (I<Count) AND (J<Limit) Do Begin { Check fully packed }
  1795. If (Items^[J]<>Nil) Then Begin { Found a valid item }
  1796. If (I<>J) Then Begin
  1797. Items^[I] := Items^[J]; { Transfer item }
  1798. Items^[J] := Nil; { Now clear old item }
  1799. End;
  1800. Inc(I); { One item packed }
  1801. End;
  1802. Inc(J); { Next item to test }
  1803. End;
  1804. If (I<Count) Then Count := I; { New packed count }
  1805. END;
  1806. {--TCollection--------------------------------------------------------------}
  1807. { FreeAll -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1808. {---------------------------------------------------------------------------}
  1809. PROCEDURE TCollection.FreeAll;
  1810. VAR I: Sw_Integer;
  1811. BEGIN
  1812. for I := Count-1 downto 0 do
  1813. FreeItem(At(I));
  1814. Count := 0; { Clear item count }
  1815. END;
  1816. {--TCollection--------------------------------------------------------------}
  1817. { DeleteAll -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1818. {---------------------------------------------------------------------------}
  1819. PROCEDURE TCollection.DeleteAll;
  1820. BEGIN
  1821. Count := 0; { Clear item count }
  1822. END;
  1823. {--TCollection--------------------------------------------------------------}
  1824. { Free -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1825. {---------------------------------------------------------------------------}
  1826. PROCEDURE TCollection.Free (Item: Pointer);
  1827. BEGIN
  1828. Delete(Item); { Delete from list }
  1829. FreeItem(Item); { Free the item }
  1830. END;
  1831. {--TCollection--------------------------------------------------------------}
  1832. { Insert -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1833. {---------------------------------------------------------------------------}
  1834. PROCEDURE TCollection.Insert (Item: Pointer);
  1835. BEGIN
  1836. AtInsert(Count, Item); { Insert item }
  1837. END;
  1838. {--TCollection--------------------------------------------------------------}
  1839. { Delete -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1840. {---------------------------------------------------------------------------}
  1841. PROCEDURE TCollection.Delete (Item: Pointer);
  1842. BEGIN
  1843. AtDelete(IndexOf(Item)); { Delete from list }
  1844. END;
  1845. {--TCollection--------------------------------------------------------------}
  1846. { AtFree -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1847. {---------------------------------------------------------------------------}
  1848. PROCEDURE TCollection.AtFree (Index: Sw_Integer);
  1849. VAR Item: Pointer;
  1850. BEGIN
  1851. Item := At(Index); { Retreive item ptr }
  1852. AtDelete(Index); { Delete item }
  1853. FreeItem(Item); { Free the item }
  1854. END;
  1855. {--TCollection--------------------------------------------------------------}
  1856. { FreeItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1857. {---------------------------------------------------------------------------}
  1858. PROCEDURE TCollection.FreeItem (Item: Pointer);
  1859. VAR P: PObject;
  1860. BEGIN
  1861. P := PObject(Item); { Convert pointer }
  1862. If (P<>Nil) Then Dispose(P, Done); { Dispose of object }
  1863. END;
  1864. {--TCollection--------------------------------------------------------------}
  1865. { AtDelete -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1866. {---------------------------------------------------------------------------}
  1867. PROCEDURE TCollection.AtDelete (Index: Sw_Integer);
  1868. BEGIN
  1869. If (Index >= 0) AND (Index < Count) Then Begin { Valid index }
  1870. Dec(Count); { One less item }
  1871. If (Count>Index) Then Move(Items^[Index+1],
  1872. Items^[Index], (Count-Index)*Sizeof(Pointer)); { Shuffle items down }
  1873. End Else Error(coIndexError, Index); { Index error }
  1874. END;
  1875. {--TCollection--------------------------------------------------------------}
  1876. { ForEach -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1877. {---------------------------------------------------------------------------}
  1878. {$PUSH}
  1879. {$W+}
  1880. PROCEDURE TCollection.ForEach (Action: CodePointer);
  1881. VAR I: LongInt;
  1882. BEGIN
  1883. For I := 1 To Count Do { Up from first item }
  1884. CallPointerLocal(Action,
  1885. { On most systems, locals are accessed relative to base pointer,
  1886. but for MIPS cpu, they are accessed relative to stack pointer.
  1887. This needs adaptation for so low level routines,
  1888. like MethodPointerLocal and related objects unit functions. }
  1889. {$ifndef FPC_LOCALS_ARE_STACK_REG_RELATIVE}
  1890. get_caller_frame(get_frame,get_pc_addr)
  1891. {$else}
  1892. get_frame
  1893. {$endif}
  1894. ,Items^[I-1]); { Call with each item }
  1895. END;
  1896. {$POP}
  1897. {--TCollection--------------------------------------------------------------}
  1898. { SetLimit -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1899. {---------------------------------------------------------------------------}
  1900. PROCEDURE TCollection.SetLimit (ALimit: Sw_Integer);
  1901. VAR
  1902. AItems: PItemList;
  1903. BEGIN
  1904. If (ALimit < Count) Then
  1905. ALimit := Count;
  1906. If (ALimit > MaxCollectionSize) Then
  1907. ALimit := MaxCollectionSize;
  1908. If (ALimit <> Limit) Then
  1909. Begin
  1910. If (ALimit = 0) Then
  1911. AItems := Nil
  1912. Else
  1913. Begin
  1914. GetMem(AItems, ALimit * SizeOf(Pointer));
  1915. If (AItems<>Nil) Then
  1916. FillChar(AItems^,ALimit * SizeOf(Pointer), #0);
  1917. End;
  1918. If (AItems<>Nil) OR (ALimit=0) Then
  1919. Begin
  1920. If (AItems <>Nil) AND (Items <> Nil) Then
  1921. Move(Items^, AItems^, Count*SizeOf(Pointer));
  1922. If (Limit <> 0) AND (Items <> Nil) Then
  1923. FreeMem(Items, Limit * SizeOf(Pointer));
  1924. end;
  1925. Items := AItems;
  1926. Limit := ALimit;
  1927. End;
  1928. END;
  1929. {--TCollection--------------------------------------------------------------}
  1930. { Error -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1931. {---------------------------------------------------------------------------}
  1932. PROCEDURE TCollection.Error (Code, Info: Integer);
  1933. BEGIN
  1934. RunError(212 - Code); { Run error }
  1935. END;
  1936. {--TCollection--------------------------------------------------------------}
  1937. { AtPut -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1938. {---------------------------------------------------------------------------}
  1939. PROCEDURE TCollection.AtPut (Index: Sw_Integer; Item: Pointer);
  1940. BEGIN
  1941. If (Index >= 0) AND (Index < Count) Then { Index valid }
  1942. Items^[Index] := Item { Put item in index }
  1943. Else Error(coIndexError, Index); { Index error }
  1944. END;
  1945. {--TCollection--------------------------------------------------------------}
  1946. { AtInsert -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1947. {---------------------------------------------------------------------------}
  1948. PROCEDURE TCollection.AtInsert (Index: Sw_Integer; Item: Pointer);
  1949. VAR I: Sw_Integer;
  1950. BEGIN
  1951. If (Index >= 0) AND (Index <= Count) Then Begin { Valid index }
  1952. If (Count=Limit) Then SetLimit(Limit+Delta); { Expand size if able }
  1953. If (Limit>Count) Then Begin
  1954. If (Index < Count) Then Begin { Not last item }
  1955. For I := Count-1 DownTo Index Do { Start from back }
  1956. Items^[I+1] := Items^[I]; { Move each item }
  1957. End;
  1958. Items^[Index] := Item; { Put item in list }
  1959. Inc(Count); { Inc count }
  1960. End Else Error(coOverflow, Index); { Expand failed }
  1961. End Else Error(coIndexError, Index); { Index error }
  1962. END;
  1963. {--TCollection--------------------------------------------------------------}
  1964. { Store -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  1965. {---------------------------------------------------------------------------}
  1966. PROCEDURE TCollection.Store (Var S: TStream);
  1967. var
  1968. LimitWord, DeltaWord: Word;
  1969. PROCEDURE DoPutItem (P: Pointer);{$IFNDEF FPC}FAR;{$ENDIF}
  1970. BEGIN
  1971. PutItem(S, P); { Put item on stream }
  1972. END;
  1973. BEGIN
  1974. If S.TPCompatible Then Begin
  1975. { Check if it is safe to write in TP-compatible stream.
  1976. If Count is too big, signal an error.
  1977. If Limit or Delta are too big, write smaller values. }
  1978. If (Count > MaxTPCompatibleCollectionSize)
  1979. Then S.Error(stWriteError, 0)
  1980. Else Begin
  1981. S.Write(Count, Sizeof(Word));
  1982. if Limit > MaxTPCompatibleCollectionSize
  1983. then LimitWord := MaxTPCompatibleCollectionSize
  1984. else LimitWord := Limit;
  1985. S.Write(LimitWord, Sizeof(Word));
  1986. if Delta > MaxTPCompatibleCollectionSize
  1987. then DeltaWord := MaxTPCompatibleCollectionSize
  1988. else DeltaWord := Delta;
  1989. S.Write(DeltaWord, Sizeof(Word));
  1990. End
  1991. End
  1992. Else Begin
  1993. S.Write(Count, Sizeof(Count)); { Write count }
  1994. S.Write(Limit, Sizeof(Limit)); { Write limit }
  1995. S.Write(Delta, Sizeof(Delta)); { Write delta }
  1996. End;
  1997. ForEach(@DoPutItem); { Each item to stream }
  1998. END;
  1999. {--TCollection--------------------------------------------------------------}
  2000. { PutItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  2001. {---------------------------------------------------------------------------}
  2002. PROCEDURE TCollection.PutItem (Var S: TStream; Item: Pointer);
  2003. BEGIN
  2004. S.Put(Item); { Put item on stream }
  2005. END;
  2006. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2007. { TSortedCollection OBJECT METHODS }
  2008. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2009. {--TSortedCollection--------------------------------------------------------}
  2010. { Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  2011. {---------------------------------------------------------------------------}
  2012. CONSTRUCTOR TSortedCollection.Init (ALimit, ADelta: Sw_Integer);
  2013. BEGIN
  2014. Inherited Init(ALimit, ADelta); { Call ancestor }
  2015. Duplicates := False; { Clear flag }
  2016. END;
  2017. {--TSortedCollection--------------------------------------------------------}
  2018. { Load -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  2019. {---------------------------------------------------------------------------}
  2020. CONSTRUCTOR TSortedCollection.Load (Var S: TStream);
  2021. BEGIN
  2022. Inherited Load(S); { Call ancestor }
  2023. S.Read(Duplicates, SizeOf(Duplicates)); { Read duplicate flag }
  2024. END;
  2025. {--TSortedCollection--------------------------------------------------------}
  2026. { KeyOf -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  2027. {---------------------------------------------------------------------------}
  2028. FUNCTION TSortedCollection.KeyOf (Item: Pointer): Pointer;
  2029. BEGIN
  2030. KeyOf := Item; { Return item as key }
  2031. END;
  2032. {--TSortedCollection--------------------------------------------------------}
  2033. { IndexOf -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  2034. {---------------------------------------------------------------------------}
  2035. FUNCTION TSortedCollection.IndexOf (Item: Pointer): Sw_Integer;
  2036. VAR I, J: Sw_Integer;
  2037. BEGIN
  2038. J := -1; { Preset result }
  2039. If Search(KeyOf(Item), I) Then Begin { Search for item }
  2040. If Duplicates Then { Duplicates allowed }
  2041. While (I < Count) AND (Item <> Items^[I]) Do
  2042. Inc(I); { Count duplicates }
  2043. If (I < Count) Then J := I; { Index result }
  2044. End;
  2045. IndexOf := J; { Return result }
  2046. END;
  2047. {--TSortedCollection--------------------------------------------------------}
  2048. { Compare -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  2049. {---------------------------------------------------------------------------}
  2050. FUNCTION TSortedCollection.Compare (Key1, Key2: Pointer): Sw_Integer;
  2051. BEGIN
  2052. Abstract; { Abstract method }
  2053. Compare:=0;
  2054. END;
  2055. {--TSortedCollection--------------------------------------------------------}
  2056. { Search -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  2057. {---------------------------------------------------------------------------}
  2058. FUNCTION TSortedCollection.Search (Key: Pointer; Var Index: Sw_Integer): Boolean;
  2059. VAR L, H, I, C: Sw_Integer;
  2060. BEGIN
  2061. Search := False; { Preset failure }
  2062. L := 0; { Start count }
  2063. H := Count - 1; { End count }
  2064. Index := 0;
  2065. if Count=0 then
  2066. exit;
  2067. While (L <= H) Do Begin
  2068. I := (L + H) SHR 1; { Mid point }
  2069. C := Compare(KeyOf(Items^[I]), Key); { Compare with key }
  2070. If (C < 0) Then L := I + 1 Else Begin { Item to left }
  2071. H := I - 1; { Item to right }
  2072. If C = 0 Then Begin { Item match found }
  2073. Search := True; { Result true }
  2074. If NOT Duplicates Then L := I; { Force kick out }
  2075. End;
  2076. End;
  2077. End;
  2078. Index := L; { Return result }
  2079. END;
  2080. {--TSortedCollection--------------------------------------------------------}
  2081. { Insert -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  2082. {---------------------------------------------------------------------------}
  2083. PROCEDURE TSortedCollection.Insert (Item: Pointer);
  2084. VAR I: Sw_Integer;
  2085. BEGIN
  2086. If NOT Search(KeyOf(Item), I) OR Duplicates Then { Item valid }
  2087. AtInsert(I, Item); { Insert the item }
  2088. END;
  2089. {--TSortedCollection--------------------------------------------------------}
  2090. { Store -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  2091. {---------------------------------------------------------------------------}
  2092. PROCEDURE TSortedCollection.Store (Var S: TStream);
  2093. BEGIN
  2094. TCollection.Store(S); { Call ancestor }
  2095. S.Write(Duplicates, SizeOf(Duplicates)); { Write duplicate flag }
  2096. END;
  2097. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2098. { TStringCollection OBJECT METHODS }
  2099. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2100. {--TStringCollection--------------------------------------------------------}
  2101. { GetItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  2102. {---------------------------------------------------------------------------}
  2103. FUNCTION TStringCollection.GetItem (Var S: TStream): Pointer;
  2104. BEGIN
  2105. GetItem := S.ReadStr; { Get new item }
  2106. END;
  2107. {--TStringCollection--------------------------------------------------------}
  2108. { Compare -> Platforms DOS/DPMI/WIN/OS2 - Checked 21Aug97 LdB }
  2109. {---------------------------------------------------------------------------}
  2110. FUNCTION TStringCollection.Compare (Key1, Key2: Pointer): Sw_Integer;
  2111. VAR I, J: Sw_Integer; P1, P2: PString;
  2112. BEGIN
  2113. P1 := PString(Key1); { String 1 pointer }
  2114. P2 := PString(Key2); { String 2 pointer }
  2115. If (Length(P1^)<Length(P2^)) Then J := Length(P1^)
  2116. Else J := Length(P2^); { Shortest length }
  2117. I := 1; { First character }
  2118. While (I<J) AND (P1^[I]=P2^[I]) Do Inc(I); { Scan till fail }
  2119. If (I=J) Then Begin { Possible match }
  2120. { * REMARK * - Bug fix 21 August 1997 }
  2121. If (P1^[I]<P2^[I]) Then Compare := -1 Else { String1 < String2 }
  2122. If (P1^[I]>P2^[I]) Then Compare := 1 Else { String1 > String2 }
  2123. If (Length(P1^)>Length(P2^)) Then Compare := 1 { String1 > String2 }
  2124. Else If (Length(P1^)<Length(P2^)) Then { String1 < String2 }
  2125. Compare := -1 Else Compare := 0; { String1 = String2 }
  2126. { * REMARK END * - Leon de Boer }
  2127. End Else If (P1^[I]<P2^[I]) Then Compare := -1 { String1 < String2 }
  2128. Else Compare := 1; { String1 > String2 }
  2129. END;
  2130. {--TStringCollection--------------------------------------------------------}
  2131. { FreeItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  2132. {---------------------------------------------------------------------------}
  2133. PROCEDURE TStringCollection.FreeItem (Item: Pointer);
  2134. BEGIN
  2135. DisposeStr(Item); { Dispose item }
  2136. END;
  2137. {--TStringCollection--------------------------------------------------------}
  2138. { PutItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB }
  2139. {---------------------------------------------------------------------------}
  2140. PROCEDURE TStringCollection.PutItem (Var S: TStream; Item: Pointer);
  2141. BEGIN
  2142. S.WriteStr(Item); { Write string }
  2143. END;
  2144. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2145. { TStrCollection OBJECT METHODS }
  2146. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2147. {--TStrCollection-----------------------------------------------------------}
  2148. { Compare -> Platforms DOS/DPMI/WIN/OS2 - Checked 23May96 LdB }
  2149. {---------------------------------------------------------------------------}
  2150. FUNCTION TStrCollection.Compare (Key1, Key2: Pointer): Sw_Integer;
  2151. VAR I, J: Sw_Integer; P1, P2: PByteArray;
  2152. BEGIN
  2153. P1 := PByteArray(Key1); { PChar 1 pointer }
  2154. P2 := PByteArray(Key2); { PChar 2 pointer }
  2155. I := 0; { Preset no size }
  2156. If (P1<>Nil) Then While (P1^[I]<>0) Do Inc(I); { PChar 1 length }
  2157. J := 0; { Preset no size }
  2158. If (P2<>Nil) Then While (P2^[J]<>0) Do Inc(J); { PChar 2 length }
  2159. If (I < J) Then J := I; { Shortest length }
  2160. I := 0; { First character }
  2161. While (I<J) AND (P1^[I]=P2^[I]) Do Inc(I); { Scan till fail }
  2162. If (P1^[I]=P2^[I]) Then Compare := 0 Else { Strings matched }
  2163. If (P1^[I]<P2^[I]) Then Compare := -1 Else { String1 < String2 }
  2164. Compare := 1; { String1 > String2 }
  2165. END;
  2166. {--TStrCollection-----------------------------------------------------------}
  2167. { GetItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 23May96 LdB }
  2168. {---------------------------------------------------------------------------}
  2169. FUNCTION TStrCollection.GetItem (Var S: TStream): Pointer;
  2170. BEGIN
  2171. GetItem := S.StrRead; { Get string item }
  2172. END;
  2173. {--TStrCollection-----------------------------------------------------------}
  2174. { FreeItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 23May96 LdB }
  2175. {---------------------------------------------------------------------------}
  2176. PROCEDURE TStrCollection.FreeItem (Item: Pointer);
  2177. VAR I: Sw_Integer; P: PByteArray;
  2178. BEGIN
  2179. If (Item<>Nil) Then Begin { Item is valid }
  2180. P := PByteArray(Item); { Create byte pointer }
  2181. I := 0; { Preset no size }
  2182. While (P^[I]<>0) Do Inc(I); { Find PChar end }
  2183. FreeMem(Item, I+1); { Release memory }
  2184. End;
  2185. END;
  2186. {--TStrCollection-----------------------------------------------------------}
  2187. { PutItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 23May96 LdB }
  2188. {---------------------------------------------------------------------------}
  2189. PROCEDURE TStrCollection.PutItem (Var S: TStream; Item: Pointer);
  2190. BEGIN
  2191. S.StrWrite(Item); { Write the string }
  2192. END;
  2193. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2194. { TUnSortedStrCollection OBJECT METHODS }
  2195. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2196. {--TUnSortedCollection------------------------------------------------------}
  2197. { Insert -> Platforms DOS/DPMI/WIN/OS2 - Checked 23May96 LdB }
  2198. {---------------------------------------------------------------------------}
  2199. PROCEDURE TUnSortedStrCollection.Insert (Item: Pointer);
  2200. BEGIN
  2201. AtInsert(Count, Item); { Insert - NO sorting }
  2202. END;
  2203. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2204. { TResourceItem RECORD }
  2205. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2206. TYPE
  2207. TResourceItem = packed RECORD
  2208. Posn: LongInt; { Resource position }
  2209. Size: LongInt; { Resource size }
  2210. Key : String; { Resource key }
  2211. End;
  2212. PResourceItem = ^TResourceItem;
  2213. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2214. { TResourceCollection OBJECT METHODS }
  2215. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2216. {--TResourceCollection------------------------------------------------------}
  2217. { KeyOf -> Platforms DOS/DPMI/WIN/OS2 - Checked 24May96 LdB }
  2218. {---------------------------------------------------------------------------}
  2219. FUNCTION TResourceCollection.KeyOf (Item: Pointer): Pointer;
  2220. BEGIN
  2221. KeyOf := @PResourceItem(Item)^.Key; { Pointer to key }
  2222. END;
  2223. {--TResourceCollection------------------------------------------------------}
  2224. { GetItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 24May96 LdB }
  2225. {---------------------------------------------------------------------------}
  2226. FUNCTION TResourceCollection.GetItem (Var S: TStream): Pointer;
  2227. VAR B: Byte; Pos: Longint; Size: Longint; Ts: String; P: PResourceItem;
  2228. BEGIN
  2229. S.Read(Pos, SizeOf(Pos)); { Read position }
  2230. S.Read(Size, SizeOf(Size)); { Read size }
  2231. S.Read(B, 1); { Read key length }
  2232. GetMem(P, B + (SizeOf(TResourceItem) -
  2233. SizeOf(Ts) + 1)); { Allocate min memory }
  2234. If (P<>Nil) Then Begin { If allocate works }
  2235. P^.Posn := Pos; { Xfer position }
  2236. P^.Size := Size; { Xfer size }
  2237. P^.Key[0] := Char(B); { Xfer string length }
  2238. S.Read(P^.Key[1], B); { Xfer string data }
  2239. End;
  2240. GetItem := P; { Return pointer }
  2241. END;
  2242. {--TResourceCollection------------------------------------------------------}
  2243. { FreeItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 24May96 LdB }
  2244. {---------------------------------------------------------------------------}
  2245. PROCEDURE TResourceCollection.FreeItem (Item: Pointer);
  2246. VAR Ts: String;
  2247. BEGIN
  2248. If (Item<>Nil) Then FreeMem(Item,
  2249. SizeOf(TResourceItem) - SizeOf(Ts) +
  2250. Length(PResourceItem(Item)^.Key) + 1); { Release memory }
  2251. END;
  2252. {--TResourceCollection------------------------------------------------------}
  2253. { PutItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 24May96 LdB }
  2254. {---------------------------------------------------------------------------}
  2255. PROCEDURE TResourceCollection.PutItem (Var S: TStream; Item: Pointer);
  2256. VAR Ts: String;
  2257. BEGIN
  2258. If (Item<>Nil) Then S.Write(PResourceItem(Item)^,
  2259. SizeOf(TResourceItem) - SizeOf(Ts) +
  2260. Length(PResourceItem(Item)^.Key) + 1); { Write to stream }
  2261. END;
  2262. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2263. { PRIVATE RESOURCE MANAGER CONSTANTS }
  2264. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2265. CONST
  2266. RStreamMagic: LongInt = $52504246; { 'FBPR' }
  2267. RStreamBackLink: LongInt = $4C424246; { 'FBBL' }
  2268. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2269. { PRIVATE RESOURCE MANAGER TYPES }
  2270. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2271. TYPE
  2272. {$IFDEF NewExeFormat} { New EXE format }
  2273. TExeHeader = packed RECORD
  2274. eHdrSize: Word;
  2275. eMinAbove: Word;
  2276. eMaxAbove: Word;
  2277. eInitSS: Word;
  2278. eInitSP: Word;
  2279. eCheckSum: Word;
  2280. eInitPC: Word;
  2281. eInitCS: Word;
  2282. eRelocOfs: Word;
  2283. eOvlyNum: Word;
  2284. eRelocTab: Word;
  2285. eSpace: Array[1..30] of Byte;
  2286. eNewHeader: Word;
  2287. END;
  2288. {$ENDIF}
  2289. THeader = packed RECORD
  2290. Signature: Word;
  2291. Case Integer Of
  2292. 0: (
  2293. LastCount: Word;
  2294. PageCount: Word;
  2295. ReloCount: Word);
  2296. 1: (
  2297. InfoType: Word;
  2298. InfoSize: Longint);
  2299. End;
  2300. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2301. { TResourceFile OBJECT METHODS }
  2302. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2303. {--TResourceFile------------------------------------------------------------}
  2304. { Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB }
  2305. {---------------------------------------------------------------------------}
  2306. CONSTRUCTOR TResourceFile.Init(AStream: PStream);
  2307. VAR Found, Stop: Boolean; Header: THeader;
  2308. {$IFDEF NewExeFormat} ExeHeader: TExeHeader; {$ENDIF}
  2309. BEGIN
  2310. TObject.Init; { Initialize object }
  2311. Found := False; { Preset false }
  2312. If (AStream<>Nil) Then Begin
  2313. Stream := AStream; { Hold stream }
  2314. BasePos := Stream^.GetPos; { Get position }
  2315. Repeat
  2316. Stop := True; { Preset stop }
  2317. If (BasePos <= Stream^.GetSize-SizeOf(THeader))
  2318. Then Begin { Valid file header }
  2319. Stream^.Seek(BasePos); { Seek to position }
  2320. Stream^.Read(Header, SizeOf(THeader)); { Read header }
  2321. Case Header.Signature Of
  2322. {$IFDEF NewExeFormat} { New format file }
  2323. $5A4D: Begin
  2324. Stream^.Read(ExeHeader, SizeOf(TExeHeader));
  2325. BasePos := ExeHeader.eNewHeader; { Hold position }
  2326. Stop := False; { Clear stop flag }
  2327. End;
  2328. $454E: Begin
  2329. BasePos := Stream^.GetSize - 8; { Hold position }
  2330. Stop := False; { Clear stop flag }
  2331. End;
  2332. $4246: Begin
  2333. Stop := False; { Clear stop flag }
  2334. Case Header.Infotype Of
  2335. $5250: Begin { Found Resource }
  2336. Found := True; { Found flag is true }
  2337. Stop := True; { Set stop flag }
  2338. End;
  2339. $4C42: Dec(BasePos, Header.InfoSize-8);{ Found BackLink }
  2340. $4648: Dec(BasePos, SizeOf(THeader)*2);{ Found HelpFile }
  2341. Else Stop := True; { Set stop flag }
  2342. End;
  2343. End;
  2344. $424E: If Header.InfoType = $3230 { Found Debug Info }
  2345. Then Begin
  2346. Dec(BasePos, Header.InfoSize); { Adjust position }
  2347. Stop := False; { Clear stop flag }
  2348. End;
  2349. {$ELSE}
  2350. $5A4D: Begin
  2351. Inc(BasePos, LongInt(Header.PageCount)*512
  2352. - (-Header.LastCount AND 511)); { Calc position }
  2353. Stop := False; { Clear stop flag }
  2354. End;
  2355. $4246: If Header.InfoType = $5250 Then { Header was found }
  2356. Found := True Else Begin
  2357. Inc(BasePos, Header.InfoSize + 8); { Adjust position }
  2358. Stop := False; { Clear stop flag }
  2359. End;
  2360. {$ENDIF}
  2361. End;
  2362. End;
  2363. Until Stop; { Until flag is set }
  2364. End;
  2365. If Found Then Begin { Resource was found }
  2366. Stream^.Seek(BasePos + SizeOf(LongInt) * 2); { Seek to position }
  2367. Stream^.Read(IndexPos, SizeOf(LongInt)); { Read index position }
  2368. Stream^.Seek(BasePos + IndexPos); { Seek to resource }
  2369. Index.Load(Stream^); { Load resource }
  2370. End Else Begin
  2371. IndexPos := SizeOf(LongInt) * 3; { Set index position }
  2372. Index.Init(0, 8); { Set index }
  2373. End;
  2374. END;
  2375. {--TResourceFile------------------------------------------------------------}
  2376. { Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB }
  2377. {---------------------------------------------------------------------------}
  2378. DESTRUCTOR TResourceFile.Done;
  2379. BEGIN
  2380. Flush; { Flush the file }
  2381. Index.Done; { Dispose of index }
  2382. If (Stream<>Nil) Then Dispose(Stream, Done); { Dispose of stream }
  2383. END;
  2384. {--TResourceFile------------------------------------------------------------}
  2385. { Count -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB }
  2386. {---------------------------------------------------------------------------}
  2387. FUNCTION TResourceFile.Count: Sw_Integer;
  2388. BEGIN
  2389. Count := Index.Count; { Return index count }
  2390. END;
  2391. {--TResourceFile------------------------------------------------------------}
  2392. { KeyAt -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB }
  2393. {---------------------------------------------------------------------------}
  2394. FUNCTION TResourceFile.KeyAt (I: Sw_Integer): String;
  2395. BEGIN
  2396. KeyAt := PResourceItem(Index.At(I))^.Key; { Return key }
  2397. END;
  2398. {--TResourceFile------------------------------------------------------------}
  2399. { Get -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB }
  2400. {---------------------------------------------------------------------------}
  2401. FUNCTION TResourceFile.Get (Key: String): PObject;
  2402. VAR I: Sw_Integer;
  2403. BEGIN
  2404. If (Stream = Nil) OR (NOT Index.Search(@Key, I)) { No match on key }
  2405. Then Get := Nil Else Begin
  2406. Stream^.Seek(BasePos +
  2407. PResourceItem(Index.At(I))^.Posn); { Seek to position }
  2408. Get := Stream^.Get; { Get item }
  2409. End;
  2410. END;
  2411. {--TResourceFile------------------------------------------------------------}
  2412. { SwitchTo -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB }
  2413. {---------------------------------------------------------------------------}
  2414. FUNCTION TResourceFile.SwitchTo (AStream: PStream; Pack: Boolean): PStream;
  2415. VAR NewBasePos: LongInt;
  2416. PROCEDURE DoCopyResource (Item: PResourceItem);{$IFNDEF FPC}FAR;{$ENDIF}
  2417. BEGIN
  2418. Stream^.Seek(BasePos + Item^.Posn); { Move stream position }
  2419. Item^.Posn := AStream^.GetPos - NewBasePos; { Hold new position }
  2420. AStream^.CopyFrom(Stream^, Item^.Size); { Copy the item }
  2421. END;
  2422. BEGIN
  2423. SwitchTo := Stream; { Preset return }
  2424. If (AStream<>Nil) AND (Stream<>Nil) Then Begin { Both streams valid }
  2425. NewBasePos := AStream^.GetPos; { Get position }
  2426. If Pack Then Begin
  2427. AStream^.Seek(NewBasePos + SizeOf(LongInt)*3); { Seek to position }
  2428. Index.ForEach(@DoCopyResource); { Copy each resource }
  2429. IndexPos := AStream^.GetPos - NewBasePos; { Hold index position }
  2430. End Else Begin
  2431. Stream^.Seek(BasePos); { Seek to position }
  2432. AStream^.CopyFrom(Stream^, IndexPos); { Copy the resource }
  2433. End;
  2434. Stream := AStream; { Hold new stream }
  2435. BasePos := NewBasePos; { New base position }
  2436. Modified := True; { Set modified flag }
  2437. End;
  2438. END;
  2439. {--TResourceFile------------------------------------------------------------}
  2440. { Flush -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB }
  2441. {---------------------------------------------------------------------------}
  2442. PROCEDURE TResourceFile.Flush;
  2443. VAR ResSize: LongInt; LinkSize: LongInt;
  2444. BEGIN
  2445. If (Modified) AND (Stream<>Nil) Then Begin { We have modification }
  2446. Stream^.Seek(BasePos + IndexPos); { Seek to position }
  2447. Index.Store(Stream^); { Store the item }
  2448. ResSize := Stream^.GetPos - BasePos; { Hold position }
  2449. LinkSize := ResSize + SizeOf(LongInt) * 2; { Hold link size }
  2450. Stream^.Write(RStreamBackLink, SizeOf(LongInt)); { Write link back }
  2451. Stream^.Write(LinkSize, SizeOf(LongInt)); { Write link size }
  2452. Stream^.Seek(BasePos); { Move stream position }
  2453. Stream^.Write(RStreamMagic, SizeOf(LongInt)); { Write number }
  2454. Stream^.Write(ResSize, SizeOf(LongInt)); { Write record size }
  2455. Stream^.Write(IndexPos, SizeOf(LongInt)); { Write index position }
  2456. Stream^.Flush; { Flush the stream }
  2457. End;
  2458. Modified := False; { Clear modified flag }
  2459. END;
  2460. {--TResourceFile------------------------------------------------------------}
  2461. { Delete -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB }
  2462. {---------------------------------------------------------------------------}
  2463. PROCEDURE TResourceFile.Delete (Key: String);
  2464. VAR I: Sw_Integer;
  2465. BEGIN
  2466. If Index.Search(@Key, I) Then Begin { Search for key }
  2467. Index.Free(Index.At(I)); { Delete from index }
  2468. Modified := True; { Set modified flag }
  2469. End;
  2470. END;
  2471. {--TResourceFile------------------------------------------------------------}
  2472. { Put -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB }
  2473. {---------------------------------------------------------------------------}
  2474. PROCEDURE TResourceFile.Put (Item: PObject; Key: String);
  2475. VAR I: Sw_Integer; Ts: String; P: PResourceItem;
  2476. BEGIN
  2477. If (Stream=Nil) Then Exit; { Stream not valid }
  2478. If Index.Search(@Key, I) Then P := Index.At(I) { Search for item }
  2479. Else Begin
  2480. GetMem(P, Length(Key) + (SizeOf(TResourceItem) -
  2481. SizeOf(Ts) + 1)); { Allocate memory }
  2482. If (P<>Nil) Then Begin
  2483. P^.Key := Key; { Store key }
  2484. Index.AtInsert(I, P); { Insert item }
  2485. End;
  2486. End;
  2487. If (P<>Nil) Then Begin
  2488. P^.Posn := IndexPos; { Set index position }
  2489. Stream^.Seek(BasePos + IndexPos); { Seek file position }
  2490. Stream^.Put(Item); { Put item on stream }
  2491. IndexPos := Stream^.GetPos - BasePos; { Hold index position }
  2492. P^.Size := IndexPos - P^.Posn; { Calc size }
  2493. Modified := True; { Set modified flag }
  2494. End;
  2495. END;
  2496. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2497. { TStringList OBJECT METHODS }
  2498. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2499. {--TStringList--------------------------------------------------------------}
  2500. { Load -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB }
  2501. {---------------------------------------------------------------------------}
  2502. CONSTRUCTOR TStringList.Load (Var S: TStream);
  2503. VAR Size: Word;
  2504. BEGIN
  2505. Stream := @S; { Hold stream pointer }
  2506. S.Read(Size, SizeOf(Word)); { Read size }
  2507. BasePos := S.GetPos; { Hold position }
  2508. S.Seek(BasePos + Size); { Seek to position }
  2509. S.Read(IndexSize, SizeOf(Integer)); { Read index size }
  2510. GetMem(Index, IndexSize * SizeOf(TStrIndexRec)); { Allocate memory }
  2511. S.Read(Index^, IndexSize * SizeOf(TStrIndexRec)); { Read indexes }
  2512. END;
  2513. {--TStringList--------------------------------------------------------------}
  2514. { Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB }
  2515. {---------------------------------------------------------------------------}
  2516. DESTRUCTOR TStringList.Done;
  2517. BEGIN
  2518. FreeMem(Index, IndexSize * SizeOf(TStrIndexRec)); { Release memory }
  2519. END;
  2520. {--TStringList--------------------------------------------------------------}
  2521. { Get -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB }
  2522. {---------------------------------------------------------------------------}
  2523. FUNCTION TStringList.Get (Key: Sw_Word): String;
  2524. VAR I: Word; S: String;
  2525. BEGIN
  2526. S := ''; { Preset empty string }
  2527. If (IndexSize>0) Then Begin { We must have strings }
  2528. I := 0; { First entry }
  2529. While (I<IndexSize) AND (S='') Do Begin
  2530. If ((Key - Index^[I].Key)<Index^[I].Count) { Diff less than count }
  2531. Then ReadStr(S, Index^[I].Offset,
  2532. Key-Index^[I].Key); { Read the string }
  2533. Inc(I); { Next entry }
  2534. End;
  2535. End;
  2536. Get := S; { Return empty string }
  2537. END;
  2538. {***************************************************************************}
  2539. { TStringList PRIVATE METHODS }
  2540. {***************************************************************************}
  2541. {--TStringLis---------------------------------------------------------------}
  2542. { ReadStr -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB }
  2543. {---------------------------------------------------------------------------}
  2544. PROCEDURE TStringList.ReadStr (Var S: String; Offset, Skip: Longint);
  2545. BEGIN
  2546. Stream^.Seek(BasePos + Offset); { Seek to position }
  2547. Inc(Skip); { Adjust skip }
  2548. Repeat
  2549. Stream^.Read(S[0], 1); { Read string size }
  2550. Stream^.Read(S[1], Ord(S[0])); { Read string data }
  2551. Dec(Skip); { One string read }
  2552. Until (Skip = 0);
  2553. END;
  2554. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2555. { TStrListMaker OBJECT METHODS }
  2556. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2557. {--TStrListMaker------------------------------------------------------------}
  2558. { Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB }
  2559. {---------------------------------------------------------------------------}
  2560. CONSTRUCTOR TStrListMaker.Init (AStrSize, AIndexSize: Sw_Word);
  2561. BEGIN
  2562. Inherited Init; { Call ancestor }
  2563. StrSize := AStrSize; { Hold size }
  2564. IndexSize := AIndexSize; { Hold index size }
  2565. GetMem(Strings, AStrSize); { Allocate memory }
  2566. GetMem(Index, AIndexSize * SizeOf(TStrIndexRec)); { Allocate memory }
  2567. END;
  2568. {--TStrListMaker------------------------------------------------------------}
  2569. { Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB }
  2570. {---------------------------------------------------------------------------}
  2571. DESTRUCTOR TStrListMaker.Done;
  2572. BEGIN
  2573. FreeMem(Index, IndexSize * SizeOf(TStrIndexRec)); { Free index memory }
  2574. FreeMem(Strings, StrSize); { Free data memory }
  2575. END;
  2576. {--TStrListMaker------------------------------------------------------------}
  2577. { Put -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB }
  2578. {---------------------------------------------------------------------------}
  2579. PROCEDURE TStrListMaker.Put (Key: Sw_Word; S: String);
  2580. BEGIN
  2581. If (Cur.Count = 16) OR (Key <> Cur.Key + Cur.Count)
  2582. Then CloseCurrent; { Close current }
  2583. If (Cur.Count = 0) Then Begin
  2584. Cur.Key := Key; { Set key }
  2585. Cur.Offset := StrPos; { Set offset }
  2586. End;
  2587. Inc(Cur.Count); { Inc count }
  2588. Move(S, Strings^[StrPos], Length(S) + 1); { Move string data }
  2589. Inc(StrPos, Length(S) + 1); { Adjust position }
  2590. END;
  2591. {--TStrListMaker------------------------------------------------------------}
  2592. { Store -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB }
  2593. {---------------------------------------------------------------------------}
  2594. PROCEDURE TStrListMaker.Store (Var S: TStream);
  2595. BEGIN
  2596. CloseCurrent; { Close all current }
  2597. S.Write(StrPos, SizeOf(Word)); { Write position }
  2598. S.Write(Strings^, StrPos); { Write string data }
  2599. S.Write(IndexPos, SizeOf(Word)); { Write index position }
  2600. S.Write(Index^, IndexPos * SizeOf(TStrIndexRec)); { Write indexes }
  2601. END;
  2602. {***************************************************************************}
  2603. { TStrListMaker PRIVATE METHODS }
  2604. {***************************************************************************}
  2605. {--TStrListMaker------------------------------------------------------------}
  2606. { CloseCurrent -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB }
  2607. {---------------------------------------------------------------------------}
  2608. PROCEDURE TStrListMaker.CloseCurrent;
  2609. BEGIN
  2610. If (Cur.Count <> 0) Then Begin
  2611. Index^[IndexPos] := Cur; { Hold index position }
  2612. Inc(IndexPos); { Next index }
  2613. Cur.Count := 0; { Adjust count }
  2614. End;
  2615. END;
  2616. {***************************************************************************}
  2617. { INTERFACE ROUTINES }
  2618. {***************************************************************************}
  2619. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2620. { DYNAMIC STRING INTERFACE ROUTINES }
  2621. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2622. {---------------------------------------------------------------------------}
  2623. { NewStr -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 12Jun96 LdB }
  2624. {---------------------------------------------------------------------------}
  2625. FUNCTION NewStr (Const S: String): PString;
  2626. VAR P: PString;
  2627. BEGIN
  2628. If (S = '') Then P := Nil Else Begin { Return nil }
  2629. GetMem(P, Length(S) + 1); { Allocate memory }
  2630. If (P<>Nil) Then P^ := S; { Hold string }
  2631. End;
  2632. NewStr := P; { Return result }
  2633. END;
  2634. {---------------------------------------------------------------------------}
  2635. { DisposeStr -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 12Jun96 LdB }
  2636. {---------------------------------------------------------------------------}
  2637. PROCEDURE DisposeStr (P: PString);
  2638. BEGIN
  2639. If (P <> Nil) Then FreeMem(P, Length(P^) + 1); { Release memory }
  2640. END;
  2641. PROCEDURE SetStr(VAR p:pString; CONST s:STRING);
  2642. BEGIN
  2643. IF p<>NIL THEN
  2644. FreeMem(P, Length(P^) + 1);
  2645. GetMem(p,LENGTH(s)+1);
  2646. pSTRING(p)^ := s
  2647. END;
  2648. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2649. { STREAM INTERFACE ROUTINES }
  2650. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2651. {---------------------------------------------------------------------------}
  2652. { Abstract -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 12Jun96 LdB }
  2653. {---------------------------------------------------------------------------}
  2654. PROCEDURE Abstract;
  2655. BEGIN
  2656. RunError(211); { Abstract error }
  2657. END;
  2658. {---------------------------------------------------------------------------}
  2659. { RegisterObjects -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 02Sep97 LdB }
  2660. {---------------------------------------------------------------------------}
  2661. PROCEDURE RegisterObjects;
  2662. BEGIN
  2663. RegisterType(RCollection); { Register object }
  2664. RegisterType(RStringCollection); { Register object }
  2665. RegisterType(RStrCollection); { Register object }
  2666. END;
  2667. {---------------------------------------------------------------------------}
  2668. { RegisterType -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 02Sep97 LdB }
  2669. {---------------------------------------------------------------------------}
  2670. PROCEDURE RegisterType (Var S: TStreamRec);
  2671. VAR P: PStreamRec;
  2672. BEGIN
  2673. P := StreamTypes; { Current reg list }
  2674. While (P <> Nil) AND (P^.ObjType <> S.ObjType)
  2675. Do P := P^.Next; { Find end of chain }
  2676. If (P = Nil) AND (S.ObjType <> 0) Then Begin { Valid end found }
  2677. S.Next := StreamTypes; { Chain the list }
  2678. StreamTypes := @S; { We are now first }
  2679. End Else RegisterError; { Register the error }
  2680. END;
  2681. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2682. { GENERAL FUNCTION INTERFACE ROUTINES }
  2683. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2684. {---------------------------------------------------------------------------}
  2685. { LongMul -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 04Sep97 LdB }
  2686. {---------------------------------------------------------------------------}
  2687. FUNCTION LongMul (X, Y: Integer): LongInt;
  2688. BEGIN
  2689. LongMul:=Longint(X*Y);
  2690. END;
  2691. {---------------------------------------------------------------------------}
  2692. { LongDiv -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 04Sep97 LdB }
  2693. {---------------------------------------------------------------------------}
  2694. FUNCTION LongDiv (X: LongInt; Y: Integer): Integer;
  2695. BEGIN
  2696. LongDiv := Integer(X DIV Y);
  2697. END;
  2698. BEGIN
  2699. invalidhandle:=UnusedHandle;
  2700. END.