objpas.inc 60 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979
  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. This unit makes Free Pascal as much as possible Delphi compatible
  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. {$ifdef FPC_HAS_FEATURE_VARIANTS}
  12. procedure DoDispCallByIDError(res : Pointer; const disp : IDispatch;desc : PDispDesc; params : Pointer);
  13. begin
  14. handleerroraddrframeind(RuntimeErrorExitCodes[reVarDispatch],
  15. get_pc_addr,get_frame);
  16. end;
  17. procedure fpc_dispatch_by_id(Result: Pointer; const Dispatch: pointer;
  18. DispDesc: Pointer; Params: Pointer); compilerproc;
  19. type
  20. TDispProc = procedure(res : Pointer; const disp : IDispatch;desc : PDispDesc; params : Pointer);
  21. begin
  22. TDispProc(DispCallByIDProc)(Result,IDispatch(Dispatch),DispDesc,Params);
  23. end;
  24. {$endif FPC_HAS_FEATURE_VARIANTS}
  25. {****************************************************************************
  26. Internal Routines called from the Compiler
  27. ****************************************************************************}
  28. { the reverse order of the parameters make code generation easier }
  29. function fpc_do_is(aclass : tclass;aobject : tobject) : boolean;[public,alias: 'FPC_DO_IS']; compilerproc;
  30. begin
  31. fpc_do_is:=assigned(aobject) and assigned(aclass) and
  32. aobject.inheritsfrom(aclass);
  33. end;
  34. {$IFDEF FPC_HAS_FEATURE_THREADING}
  35. threadvar
  36. CastErrorFrom : ShortString;
  37. CastErrorTo : ShortString;
  38. {$ELSE}
  39. var
  40. CastErrorFrom : ShortString = '';
  41. CastErrorTo : ShortString = '';
  42. {$ENDIF}
  43. procedure SetCastErrorInfo(const aFrom,aTo : shortstring);
  44. begin
  45. CastErrorFrom:=aFrom;
  46. CastErrorTo:=aTo;
  47. end;
  48. { the reverse order of the parameters make code generation easier }
  49. function fpc_do_as(aclass : tclass;aobject : tobject): tobject;[public,alias: 'FPC_DO_AS']; compilerproc;
  50. begin
  51. if assigned(aobject) and not(aobject.inheritsfrom(aclass)) then
  52. begin
  53. SetCastErrorInfo(aObject.ClassName,aClass.ClassName);
  54. handleerroraddrframeInd(219,get_pc_addr,get_frame);
  55. end;
  56. result := aobject;
  57. end;
  58. { interface helpers }
  59. procedure fpc_intf_decr_ref(var i: pointer);[public,alias: 'FPC_INTF_DECR_REF']; compilerproc;
  60. var
  61. iFetch: pointer;
  62. begin
  63. iFetch:=i;
  64. if assigned(iFetch) then
  65. begin
  66. i:=nil;
  67. IUnknown(iFetch)._Release;
  68. end;
  69. end;
  70. { local declaration for intf_decr_ref for local access }
  71. procedure intf_decr_ref(var i: pointer); [external name 'FPC_INTF_DECR_REF'];
  72. procedure fpc_intf_incr_ref(i: pointer);[public,alias: 'FPC_INTF_INCR_REF']; compilerproc;
  73. begin
  74. if assigned(i) then
  75. IUnknown(i)._AddRef;
  76. end;
  77. { local declaration of intf_incr_ref for local access }
  78. procedure intf_incr_ref(i: pointer); [external name 'FPC_INTF_INCR_REF'];
  79. procedure fpc_intf_assign(var D: pointer; const S: pointer);[public,alias: 'FPC_INTF_ASSIGN']; compilerproc;
  80. begin
  81. if assigned(S) then
  82. IUnknown(S)._AddRef;
  83. if assigned(D) then
  84. IUnknown(D)._Release;
  85. D:=S;
  86. end;
  87. procedure fpc_intf_assign(var D: pointer; const s: pointer); [external name 'FPC_INTF_ASSIGN'];
  88. {procedure fpc_intf_assign_by_iid(var D: pointer; const S: pointer; const iid: TGUID);[public,alias: 'FPC_INTF_ASSIGN2']; compilerproc;
  89. var
  90. tmp : pointer;
  91. begin
  92. if assigned(S) then
  93. begin
  94. tmp:=nil;
  95. if IUnknown(S).QueryInterface(iid,tmp)<>S_OK then
  96. handleerror(219);
  97. if assigned(D) then
  98. IUnknown(D)._Release;
  99. D:=tmp;
  100. end
  101. else
  102. begin
  103. if assigned(D) then
  104. IUnknown(D)._Release;
  105. D:=nil;
  106. end;
  107. end;}
  108. function fpc_intf_is(const S: pointer; const iid: TGUID): Boolean;[public,alias: 'FPC_INTF_IS']; compilerproc;
  109. var
  110. tmpi: pointer;
  111. begin
  112. tmpi:=nil;
  113. fpc_intf_is:=Assigned(S) and (IUnknown(S).QueryInterface(iid,tmpi)=S_OK);
  114. if Assigned(tmpi) then
  115. IUnknown(tmpi)._Release;
  116. end;
  117. function fpc_intf_is_class(const S: pointer; const aclass: tclass): Boolean;[public,alias: 'FPC_INTF_IS_CLASS']; compilerproc;
  118. var
  119. tmpo: tobject;
  120. begin
  121. fpc_intf_is_class:=Assigned(S) and (IUnknown(S).QueryInterface(IObjectInstance,tmpo)=S_OK) and tmpo.InheritsFrom(aclass);
  122. end;
  123. function fpc_class_is_intf(const S: pointer; const iid: TGUID): Boolean;[public,alias: 'FPC_CLASS_IS_INTF']; compilerproc;
  124. var
  125. tmpi: pointer;
  126. tmpi2: pointer; // weak!
  127. begin
  128. tmpi:=nil;
  129. tmpi2:=nil;
  130. fpc_class_is_intf:=Assigned(S) and ((TObject(S).GetInterfaceWeak(IUnknown,tmpi2) and (IUnknown(tmpi2).QueryInterface(IID,tmpi)=S_OK)) or
  131. TObject(S).GetInterface(IID,tmpi));
  132. if Assigned(tmpi) then
  133. IUnknown(tmpi)._Release;
  134. end;
  135. function fpc_class_is_corbaintf(const S: pointer; const iid: Shortstring): Boolean;[public,alias: 'FPC_CLASS_IS_CORBAINTF']; compilerproc;
  136. begin
  137. fpc_class_is_corbaintf:=Assigned(S) and Assigned(TObject(S).GetInterfaceEntryByStr(iid));
  138. end;
  139. function fpc_intf_cast(const S: pointer; const iid: TGUID): IInterface;[public,alias: 'FPC_INTF_CAST']; compilerproc;
  140. var
  141. tmpi: pointer;
  142. begin
  143. tmpi:=nil;
  144. if Assigned(S) and (IUnknown(S).QueryInterface(iid,tmpi)=S_OK) then
  145. pointer(fpc_intf_cast):=tmpi
  146. else
  147. fpc_intf_cast:= nil;
  148. end;
  149. function fpc_intf_cast_class(const S: pointer; const aclass: tclass): pointer;[public,alias: 'FPC_INTF_CAST_CLASS']; compilerproc;
  150. var
  151. tmpo: tobject;
  152. begin
  153. if Assigned(S) and (IUnknown(S).QueryInterface(IObjectInstance,tmpo)=S_OK) and tmpo.InheritsFrom(aclass) then
  154. fpc_intf_cast_class:=tmpo
  155. else
  156. fpc_intf_cast_class:=nil;
  157. end;
  158. function fpc_class_cast_intf(const S: pointer; const iid: TGUID): IInterface;[public,alias: 'FPC_CLASS_CAST_INTF']; compilerproc;
  159. var
  160. tmpi: pointer;
  161. tmpi2: pointer; // weak!
  162. begin
  163. tmpi:=nil;
  164. tmpi2:=nil;
  165. if Assigned(S) and ((TObject(S).GetInterfaceWeak(IUnknown,tmpi2) and (IUnknown(tmpi2).QueryInterface(IID,tmpi)=S_OK)) or
  166. TObject(S).GetInterface(IID,tmpi)) then
  167. begin
  168. // decrease reference count
  169. fpc_class_cast_intf:=nil;
  170. pointer(fpc_class_cast_intf):=tmpi
  171. end
  172. else
  173. fpc_class_cast_intf:=nil;
  174. end;
  175. function fpc_class_cast_corbaintf(const S: pointer; const iid: Shortstring): Pointer;[public,alias: 'FPC_CLASS_CAST_CORBAINTF']; compilerproc;
  176. var
  177. tmpi: pointer;
  178. begin
  179. if Assigned(S) and TObject(S).GetInterface(iid,tmpi) then
  180. fpc_class_cast_corbaintf:=tmpi
  181. else
  182. fpc_class_cast_corbaintf:=nil;
  183. end;
  184. function fpc_intf_as(const S: pointer; const iid: TGUID): IInterface;[public,alias: 'FPC_INTF_AS']; compilerproc;
  185. var
  186. tmpi: pointer; // _AddRef before _Release
  187. errObj : TObject;
  188. begin
  189. if assigned(S) then
  190. begin
  191. tmpi:=nil;
  192. if IUnknown(S).QueryInterface(iid,tmpi)<>S_OK then
  193. begin
  194. if (IUnknown(S).QueryInterface(IObjectInstance,errObj)=S_OK) then
  195. SetCastErrorInfo(errObj.ClassName,iid.AsString)
  196. else
  197. SetCastErrorInfo('External interface',iid.AsString);
  198. handleerror(219);
  199. end;
  200. // decrease reference count
  201. fpc_intf_as:=nil;
  202. pointer(fpc_intf_as):=tmpi;
  203. end
  204. else
  205. fpc_intf_as:=nil;
  206. end;
  207. function fpc_intf_as_class(const S: pointer; const aclass: tclass): pointer;[public,alias: 'FPC_INTF_AS_CLASS']; compilerproc;
  208. var
  209. tmpo: tobject;
  210. errObj : TObject;
  211. begin
  212. if assigned(S) then
  213. begin
  214. if not ((IUnknown(S).QueryInterface(IObjectInstance,tmpo)=S_OK) and tmpo.inheritsfrom(aclass)) then
  215. begin
  216. if (IUnknown(S).QueryInterface(IObjectInstance,errObj)=S_OK) then
  217. SetCastErrorInfo(errObj.ClassName,aClass.ClassName)
  218. else
  219. SetCastErrorInfo('External interface',aClass.ClassName);
  220. handleerror(219);
  221. end;
  222. fpc_intf_as_class:=tmpo;
  223. end
  224. else
  225. fpc_intf_as_class:=nil;
  226. end;
  227. function fpc_class_as_intf(const S: pointer; const iid: TGUID): IInterface;[public,alias: 'FPC_CLASS_AS_INTF']; compilerproc;
  228. var
  229. tmpi: pointer; // _AddRef before _Release
  230. tmpi2: pointer; // weak!
  231. errObj : TObject;
  232. begin
  233. if assigned(S) then
  234. begin
  235. tmpi:=nil;
  236. tmpi2:=nil;
  237. if not ((TObject(S).GetInterfaceWeak(IUnknown,tmpi2) and (IUnknown(tmpi2).QueryInterface(IID,tmpi)=S_OK)) or TObject(S).GetInterface(IID,tmpi)) then
  238. begin
  239. SetCastErrorInfo(TObject(S).ClassName,iid.AsString);
  240. handleerror(219);
  241. end;
  242. // decrease reference count
  243. fpc_class_as_intf:=nil;
  244. pointer(fpc_class_as_intf):=tmpi;
  245. end
  246. else
  247. fpc_class_as_intf:=nil;
  248. end;
  249. function fpc_class_as_corbaintf(const S: pointer; const iid: Shortstring): Pointer;[public,alias: 'FPC_CLASS_AS_CORBAINTF']; compilerproc;
  250. var
  251. tmpi: pointer; // _AddRef before _Release
  252. begin
  253. if assigned(S) then
  254. begin
  255. tmpi:=nil;
  256. if not TObject(S).GetInterface(iid,tmpi) then
  257. begin
  258. SetCastErrorInfo(TObject(S).ClassName,iid);
  259. handleerror(219);
  260. end;
  261. fpc_class_as_corbaintf:=tmpi;
  262. end
  263. else
  264. fpc_class_as_corbaintf:=nil;
  265. end;
  266. {****************************************************************************
  267. TVMT
  268. ****************************************************************************}
  269. function TVmt.GetvParent: PVmt;
  270. begin
  271. if Assigned(vParentRef) then
  272. GetvParent:=vParentRef^
  273. else
  274. GetvParent:=Nil;
  275. end;
  276. {****************************************************************************
  277. TGUID
  278. ****************************************************************************}
  279. class operator TGUID.=(const aLeft, aRight: TGUID): Boolean;
  280. var
  281. P1,P2 : ^Cardinal;
  282. begin
  283. P1:=PCardinal(@aLeft);
  284. P2:=PCardinal(@aRight);
  285. Result:=(P1[0]=P2[0]) and (P1[1]=P2[1]) and (P1[2]=P2[2]) and (P1[3]=P2[3]);
  286. end;
  287. class operator TGUID.<>(const aLeft, aRight: TGUID): Boolean;
  288. begin
  289. Result:=Not (aLeft=aRight);
  290. end;
  291. class function TGUID.Empty: TGUID; static;
  292. begin
  293. Result:=Default(TGUID);
  294. end;
  295. class function TGUID.Create(const aData; aBigEndian: Boolean = False): TGUID; overload; static;
  296. begin
  297. Result:=Create(PByte(@aData),aBigEndian);
  298. end;
  299. class function TGUID.Create(const aData : PByte; aBigEndian: Boolean = False): TGUID; overload; static;
  300. const
  301. SysBigendian = {$IFDEF FPC_LITTLE_ENDIAN} false {$ELSE} true {$ENDIF};
  302. begin
  303. Result := PGuid(aData)^;
  304. if (aBigEndian=SysBigEndian) then
  305. exit;
  306. Result.D1:=SwapEndian(Result.D1);
  307. Result.D2:=SwapEndian(Result.D2);
  308. Result.D3:=SwapEndian(Result.D3);
  309. end;
  310. class function TGUID.Create(const aData: array of Byte; aStartIndex: Cardinal; aBigEndian: Boolean = False): TGUID; overload; static;
  311. begin
  312. if ((Length(aData)-aStartIndex)<16) then
  313. Result:=Empty
  314. else
  315. Result:=Create(PByte(@aData[aStartIndex]),aBigEndian);
  316. end;
  317. function TGUID.IsEmpty: Boolean;
  318. var
  319. P : ^Cardinal;
  320. begin
  321. P:=PCardinal(@Self);
  322. Result:=(P[0]=0) and (P[1]=0) and (P[2]=0) and (P[3]=0)
  323. end;
  324. function TGUID.AsString : ShortString;
  325. begin
  326. WriteStr(Result,'{',hexstr(Longint(D1),8),
  327. '-',HexStr(D2,4),
  328. '-',HexStr(D3,4),
  329. '-',HexStr(D4[0],2), HexStr(D4[1],2),
  330. '-',HexStr(D4[2],2), HexStr(D4[3],2), HexStr(D4[4],2), HexStr(D4[5],2), HexStr(D4[6],2), HexStr(D4[7],2),
  331. '}');
  332. end;
  333. {****************************************************************************
  334. TINTERFACEENTRY
  335. ****************************************************************************}
  336. function tinterfaceentry.GetIID: pguid;
  337. begin
  338. if Assigned(IIDRef) then
  339. GetIID:=IIDRef^
  340. else
  341. GetIID:=Nil;
  342. end;
  343. function tinterfaceentry.GetIIDStr: pshortstring;
  344. begin
  345. if Assigned(IIDStrRef) then
  346. GetIIDStr:=IIDStrRef^
  347. else
  348. GetIIDStr:=Nil;
  349. end;
  350. {****************************************************************************
  351. TOBJECT
  352. ****************************************************************************}
  353. constructor TObject.Create;
  354. begin
  355. end;
  356. destructor TObject.Destroy;
  357. begin
  358. end;
  359. procedure TObject.Free;
  360. begin
  361. // the call via self avoids a warning
  362. if self<>nil then
  363. self.destroy;
  364. end;
  365. class function TObject.InstanceSize : SizeInt;
  366. begin
  367. InstanceSize := PVmt(Self)^.vInstanceSize;
  368. end;
  369. procedure InitInterfacePointers(objclass: tclass;instance : pointer);
  370. var
  371. ovmt: PVmt;
  372. i: longint;
  373. intftable: pinterfacetable;
  374. Res: pinterfaceentry;
  375. begin
  376. ovmt := PVmt(objclass);
  377. while assigned(ovmt) and assigned(ovmt^.vIntfTable) do
  378. begin
  379. intftable:=ovmt^.vIntfTable;
  380. i:=intftable^.EntryCount;
  381. Res:=@intftable^.Entries[0];
  382. while i>0 do begin
  383. if Res^.IType = etStandard then
  384. ppointer(@(pbyte(instance)[Res^.IOffset]))^:=
  385. pointer(Res^.VTable);
  386. inc(Res);
  387. dec(i);
  388. end;
  389. ovmt:=ovmt^.vParent;
  390. end;
  391. end;
  392. class function TObject.InitInstance(instance : pointer) : tobject;
  393. var
  394. vmt : PVmt;
  395. inittable : pointer;
  396. {$ifdef FPC_HAS_FEATURE_RTTI}
  397. mopinittable : PRTTIRecordOpOffsetTable;
  398. {$endif def FPC_HAS_FEATURE_RTTI}
  399. i : longint;
  400. begin
  401. { the size is saved at offset 0 }
  402. fillchar(instance^, InstanceSize, 0);
  403. { insert VMT pointer into the new created memory area }
  404. { (in class methods self contains the VMT!) }
  405. {$IFNDEF SYSTEM_HAS_FEATURE_MONITOR}
  406. ppointer(instance)^:=pointer(self);
  407. {$ELSE}
  408. {$IFDEF VER3_2}
  409. // In 3.2.x Compiler (used during bootstrap) still inserts VMT at offset...
  410. ppointer(PByte(instance)+SizeOf(Pointer))^:=pointer(self);
  411. {$ELSE}
  412. // As of 3.3.x compiler forces insert of VMT at first pos.
  413. ppointer(instance)^:=pointer(self);
  414. {$ENDIF}
  415. {$ENDIF}
  416. if assigned(PVmt(self)^.vIntfTable) then
  417. InitInterfacePointers(self,instance);
  418. {$ifdef FPC_HAS_FEATURE_RTTI}
  419. { for management operators like initialize call int_initialize }
  420. vmt := PVmt(self);
  421. if assigned(vmt) then
  422. begin
  423. inittable:=vmt^.vInitTable;
  424. if assigned(inittable) then
  425. begin
  426. mopinittable:=RTTIRecordMopInitTable(inittable);
  427. if assigned(mopinittable) then
  428. begin
  429. {$push}
  430. { ensure that no range check errors pop up with the [0..0] array }
  431. {$R-}
  432. for i:=0 to mopinittable^.Count-1 do
  433. TRTTIRecVarOp(mopinittable^.Entries[i].ManagmentOperator)(PByte(Instance)+mopinittable^.Entries[i].FieldOffset);
  434. {$pop}
  435. end;
  436. end;
  437. end;
  438. {$endif def FPC_HAS_FEATURE_RTTI}
  439. InitInstance:=TObject(Instance);
  440. end;
  441. class function TObject.ClassParent : tclass;
  442. begin
  443. { type of self is class of tobject => it points to the vmt }
  444. { the parent vmt is saved at offset vmtParent }
  445. classparent:=tclass(PVmt(Self)^.vParent);
  446. end;
  447. class function TObject.NewInstance : tobject;
  448. var
  449. p : pointer;
  450. begin
  451. getmem(p, InstanceSize);
  452. if p <> nil then
  453. InitInstance(p);
  454. NewInstance:=TObject(p);
  455. end;
  456. procedure TObject.FreeInstance;
  457. begin
  458. CleanupInstance;
  459. FreeMem(Pointer(Self));
  460. end;
  461. class function TObject.ClassType : TClass;
  462. begin
  463. ClassType:=TClass(Pointer(Self))
  464. end;
  465. type
  466. {$PUSH}
  467. {$PACKRECORDS NORMAL}
  468. tmethodnamerec =
  469. {$IFNDEF FPC_REQUIRES_PROPER_ALIGNMENT}
  470. packed
  471. {$ENDIF FPC_REQUIRES_PROPER_ALIGNMENT}
  472. record
  473. name : pshortstring;
  474. addr : codepointer;
  475. end;
  476. tmethodnametable =
  477. {$IFNDEF FPC_REQUIRES_PROPER_ALIGNMENT}
  478. packed
  479. {$ENDIF FPC_REQUIRES_PROPER_ALIGNMENT}
  480. record
  481. count : dword;
  482. entries : packed array[0..0] of tmethodnamerec;
  483. end;
  484. {$POP}
  485. pmethodnametable = ^tmethodnametable;
  486. class function TObject.MethodAddress(const name : shortstring) : codepointer;
  487. var
  488. methodtable : pmethodnametable;
  489. i : longint; // in case count=0
  490. ovmt : PVmt;
  491. begin
  492. ovmt:=PVmt(self);
  493. while assigned(ovmt) do
  494. begin
  495. methodtable:=pmethodnametable(ovmt^.vMethodTable);
  496. if assigned(methodtable) then
  497. begin
  498. for i:=0 to methodtable^.count-1 do
  499. if ShortCompareText(methodtable^.entries[i].name^, name)=0 then
  500. begin
  501. MethodAddress:=methodtable^.entries[i].addr;
  502. exit;
  503. end;
  504. end;
  505. ovmt := ovmt^.vParent;
  506. end;
  507. MethodAddress:=nil;
  508. end;
  509. class function TObject.MethodName(address : codepointer) : shortstring;
  510. var
  511. methodtable : pmethodnametable;
  512. i : longint; // in case count=0
  513. ovmt : PVmt;
  514. begin
  515. ovmt:=PVmt(self);
  516. while assigned(ovmt) do
  517. begin
  518. methodtable:=pmethodnametable(ovmt^.vMethodTable);
  519. if assigned(methodtable) then
  520. begin
  521. for i:=0 to methodtable^.count-1 do
  522. if methodtable^.entries[i].addr=address then
  523. begin
  524. MethodName:=methodtable^.entries[i].name^;
  525. exit;
  526. end;
  527. end;
  528. ovmt := ovmt^.vParent;
  529. end;
  530. MethodName:='';
  531. end;
  532. function TObject.FieldAddress(const name : shortstring) : pointer;
  533. {The following is copied to the typinfo unit. If it is changed here, change it there as well ! }
  534. type
  535. {$PUSH}
  536. {$PACKRECORDS NORMAL}
  537. PFieldInfo = ^TFieldInfo;
  538. TFieldInfo =
  539. {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
  540. packed
  541. {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
  542. record
  543. FieldOffset: SizeUInt;
  544. ClassTypeIndex: Word;
  545. Name: ShortString;
  546. end;
  547. PFieldTable = ^TFieldTable;
  548. TFieldTable =
  549. {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
  550. packed
  551. {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
  552. record
  553. FieldCount: Word;
  554. ClassTable: Pointer;
  555. { should be array[Word] of TFieldInfo; but
  556. Elements have variant size! force at least proper alignment }
  557. Fields: array[0..0] of TFieldInfo
  558. end;
  559. {$POP}
  560. var
  561. ovmt: PVmt;
  562. FieldTable: PFieldTable;
  563. FieldInfo: PFieldInfo;
  564. i: longint;
  565. begin
  566. if Length(name) > 0 then
  567. begin
  568. ovmt := PVmt(ClassType);
  569. while ovmt <> nil do
  570. begin
  571. FieldTable := PFieldTable(ovmt^.vFieldTable);
  572. if FieldTable <> nil then
  573. begin
  574. FieldInfo := @FieldTable^.Fields[0];
  575. for i := 0 to FieldTable^.FieldCount - 1 do
  576. begin
  577. if ShortCompareText(FieldInfo^.Name, name) = 0 then
  578. begin
  579. fieldaddress := Pointer(Self) + FieldInfo^.FieldOffset;
  580. exit;
  581. end;
  582. FieldInfo := PFieldInfo(PByte(@FieldInfo^.Name) + 1 + Length(FieldInfo^.Name));
  583. {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
  584. { align to largest field of TFieldInfo }
  585. FieldInfo := Align(FieldInfo, SizeOf(PtrUInt));
  586. {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
  587. end;
  588. end;
  589. { Try again with the parent class type }
  590. ovmt:=ovmt^.vParent;
  591. end;
  592. end;
  593. fieldaddress:=nil;
  594. end;
  595. function TObject.SafeCallException(exceptobject : tobject;
  596. exceptaddr : codepointer) : HResult;
  597. begin
  598. safecallexception:=E_UNEXPECTED;
  599. end;
  600. class function TObject.ClassInfo : pointer;
  601. begin
  602. ClassInfo := PVmt(Self)^.vTypeInfo;
  603. end;
  604. class function TObject.ClassName : ShortString;
  605. begin
  606. ClassName := PVmt(Self)^.vClassName^;
  607. end;
  608. class function TObject.ClassNameIs(const name : RTLString) : boolean;
  609. var
  610. SS : ShortString;
  611. begin
  612. SS:=ShortString(Name);
  613. ClassNameIs:=ShortCompareText(PVmt(Self)^.vClassName^, SS) = 0;
  614. end;
  615. class function TObject.InheritsFrom(aclass : TClass) : Boolean;
  616. var
  617. vmt: PVmt;
  618. begin
  619. if assigned(aclass) then
  620. begin
  621. vmt:=PVmt(self);
  622. while assigned(vmt) and (vmt <> PVmt(aclass)) do
  623. vmt := vmt^.vParent;
  624. InheritsFrom := (vmt = PVmt(aclass));
  625. end
  626. else
  627. inheritsFrom := False;
  628. end;
  629. class function TObject.stringmessagetable : pstringmessagetable;
  630. begin
  631. stringmessagetable:=PVmt(Self)^.vMsgStrPtr;
  632. end;
  633. type
  634. tmessagehandler = procedure(var msg) of object;
  635. procedure TObject.Dispatch(var message);
  636. type
  637. {$PUSH}
  638. {$PACKRECORDS NORMAL}
  639. PMsgIntTable = ^TMsgIntTable;
  640. TMsgIntTable = record
  641. index : dword;
  642. method : codepointer;
  643. end;
  644. PMsgInt = ^TMsgInt;
  645. TMsgInt = record
  646. count : longint;
  647. msgs : array[0..0] of TMsgIntTable;
  648. end;
  649. {$POP}
  650. var
  651. index : dword;
  652. count,i : longint;
  653. msgtable : PMsgIntTable;
  654. p : PMsgInt;
  655. ovmt : PVmt;
  656. msghandler : tmessagehandler;
  657. begin
  658. index:=dword(message);
  659. ovmt := PVmt(ClassType);
  660. while assigned(ovmt) do
  661. begin
  662. // See if we have messages at all in this class.
  663. p:=PMsgInt(ovmt^.vDynamicTable);
  664. If Assigned(p) then
  665. begin
  666. msgtable:=@p^.msgs;
  667. count:=p^.count;
  668. end
  669. else
  670. Count:=0;
  671. { later, we can implement a binary search here }
  672. for i:=0 to count-1 do
  673. begin
  674. if index=msgtable[i].index then
  675. begin
  676. TMethod(msghandler).Code:=msgtable[i].method;
  677. TMethod(msghandler).Data:=self;
  678. msghandler(message);
  679. exit;
  680. end;
  681. end;
  682. ovmt:=ovmt^.vParent;
  683. end;
  684. DefaultHandler(message);
  685. end;
  686. procedure TObject.DispatchStr(var message);
  687. var
  688. name : shortstring;
  689. count,i : longint;
  690. msgstrtable : pmsgstrtable;
  691. p: pstringmessagetable;
  692. ovmt : PVmt;
  693. msghandler : tmessagehandler;
  694. begin
  695. name:=pshortstring(@message)^;
  696. ovmt:=PVmt(ClassType);
  697. while assigned(ovmt) do
  698. begin
  699. p := ovmt^.vMsgStrPtr;
  700. if (P<>Nil) and (p^.count<>0) then
  701. begin
  702. count:=p^.count;
  703. msgstrtable:=@p^.msgstrtable;
  704. end
  705. else
  706. Count:=0;
  707. { later, we can implement a binary search here }
  708. for i:=0 to count-1 do
  709. begin
  710. if name=msgstrtable[i].name^ then
  711. begin
  712. TMethod(msghandler).Code:=msgstrtable[i].method;
  713. TMethod(msghandler).Data:=self;
  714. msghandler(message);
  715. exit;
  716. end;
  717. end;
  718. ovmt:=ovmt^.vParent;
  719. end;
  720. DefaultHandlerStr(message);
  721. end;
  722. procedure TObject.DefaultHandler(var message);
  723. begin
  724. end;
  725. procedure TObject.DefaultHandlerStr(var message);
  726. begin
  727. end;
  728. procedure TObject.CleanupInstance;
  729. var
  730. vmt : PVmt;
  731. temp : pointer;
  732. begin
  733. vmt := PVmt(ClassType);
  734. while vmt<>nil do
  735. begin
  736. Temp:= vmt^.vInitTable;
  737. {$ifdef FPC_HAS_FEATURE_RTTI}
  738. { The RTTI format matches one for records, except the type is tkClass.
  739. Since RecordRTTI does not check the type, calling it yields the desired result. }
  740. if Assigned(Temp) then
  741. RecordRTTI(Self,aligntoqword(Temp+2+PByte(Temp)[1]),@int_finalize);
  742. {$endif def FPC_HAS_FEATURE_RTTI}
  743. vmt:= vmt^.vParent;
  744. end;
  745. {$IFDEF SYSTEM_HAS_FEATURE_MONITOR}
  746. if Assigned(_MonitorData) then
  747. TMonitor.FreeMonitorData(_MonitorData);
  748. {$ENDIF}
  749. end;
  750. procedure TObject.AfterConstruction;
  751. begin
  752. end;
  753. procedure TObject.BeforeDestruction;
  754. begin
  755. end;
  756. function IsGUIDEqual(const guid1, guid2: tguid): boolean;
  757. begin
  758. IsGUIDEqual:=
  759. (guid1.D1=guid2.D1) and
  760. (PDWORD(@guid1.D2)^=PDWORD(@guid2.D2)^) and
  761. (PDWORD(@guid1.D4[0])^=PDWORD(@guid2.D4[0])^) and
  762. (PDWORD(@guid1.D4[4])^=PDWORD(@guid2.D4[4])^);
  763. end;
  764. // Use of managed types should be avoided here; implicit _Addref/_Release
  765. // will end up in unpredictable behaviour if called on CORBA interfaces.
  766. type
  767. TInterfaceGetter = procedure(out Obj) of object;
  768. TClassGetter = function: TObject of object;
  769. function GetInterfaceByEntry(Instance: pointer; IEntry: pinterfaceentry; out obj): boolean;
  770. var
  771. Getter: TMethod;
  772. begin
  773. Pointer(Obj) := nil;
  774. Getter.Data := Instance;
  775. if Assigned(IEntry) and Assigned(Instance) then
  776. begin
  777. case IEntry^.IType of
  778. etStandard:
  779. Pointer(Obj) := PByte(instance)+IEntry^.IOffset;
  780. etFieldValue, etFieldValueClass:
  781. Pointer(obj) := PPointer(PByte(Instance)+IEntry^.IOffset)^;
  782. etVirtualMethodResult:
  783. begin
  784. // IOffset is relative to the VMT, not to instance.
  785. Getter.code := PCodePointer(PByte(PPointer(Instance)^) + IEntry^.IOffset)^;
  786. TInterfaceGetter(Getter)(obj);
  787. end;
  788. etVirtualMethodClass:
  789. begin
  790. // IOffset is relative to the VMT, not to instance.
  791. Getter.code := PCodePointer(PByte(PPointer(Instance)^) + IEntry^.IOffset)^;
  792. TObject(obj) := TClassGetter(Getter)();
  793. end;
  794. etStaticMethodResult:
  795. begin
  796. Getter.code := IEntry^.IOffsetAsCodePtr;
  797. TInterfaceGetter(Getter)(obj);
  798. end;
  799. etStaticMethodClass:
  800. begin
  801. Getter.code := IEntry^.IOffsetAsCodePtr;
  802. TObject(obj) := TClassGetter(Getter)();
  803. end;
  804. end;
  805. end;
  806. result := assigned(pointer(obj));
  807. end;
  808. function TObject.GetInterface(const iid : tguid;out obj) : boolean;
  809. var
  810. IEntry: PInterfaceEntry;
  811. Instance: TObject;
  812. begin
  813. if IsGUIDEqual(IObjectInstance,iid) then
  814. begin
  815. TObject(Obj) := Self;
  816. Result := True;
  817. Exit;
  818. end;
  819. Instance := self;
  820. repeat
  821. IEntry := Instance.GetInterfaceEntry(iid);
  822. result := GetInterfaceByEntry(Instance, IEntry, obj);
  823. if (not result) or
  824. (IEntry^.IType in [etStandard, etFieldValue,
  825. etStaticMethodResult, etVirtualMethodResult]) then
  826. Break;
  827. { if interface is implemented by a class-type property or field,
  828. continue search }
  829. Instance := TObject(obj);
  830. until False;
  831. { Getter function will normally AddRef, so adding another reference here
  832. will cause memleak. }
  833. if result and (IEntry^.IType in [etStandard, etFieldValue]) then
  834. IInterface(obj)._AddRef;
  835. end;
  836. function TObject.GetInterfaceWeak(const iid : tguid; out obj) : boolean;
  837. var
  838. IEntry: PInterfaceEntry;
  839. Instance: TObject;
  840. begin
  841. if IsGUIDEqual(IObjectInstance,iid) then
  842. begin
  843. TObject(Obj) := Self;
  844. Result := True;
  845. Exit;
  846. end;
  847. Instance := self;
  848. repeat
  849. IEntry := Instance.GetInterfaceEntry(iid);
  850. result := GetInterfaceByEntry(Instance, IEntry, obj);
  851. if (not result) or
  852. (IEntry^.IType in [etStandard, etFieldValue,
  853. etStaticMethodResult, etVirtualMethodResult]) then
  854. Break;
  855. { if interface is implemented by a class-type property or field,
  856. continue search }
  857. Instance := TObject(obj);
  858. until False;
  859. { Getter function will normally AddRef, so we have to release it,
  860. else the ref is not weak. }
  861. if result and not (IEntry^.IType in [etStandard, etFieldValue]) then
  862. IInterface(obj)._Release;
  863. end;
  864. function TObject.GetInterfaceByStr(const iidstr : shortstring;out obj) : boolean;
  865. var
  866. IEntry: PInterfaceEntry;
  867. Instance: TObject;
  868. begin
  869. Instance := self;
  870. repeat
  871. IEntry := Instance.GetInterfaceEntryByStr(iidstr);
  872. result := GetInterfaceByEntry(Instance, IEntry, obj);
  873. if (not result) or
  874. (IEntry^.IType in [etStandard, etFieldValue,
  875. etStaticMethodResult, etVirtualMethodResult]) then
  876. Break;
  877. { if interface is implemented by a class-type property or field,
  878. continue search }
  879. Instance := TObject(obj);
  880. until False;
  881. { Getter function will normally AddRef, so adding another reference here
  882. will cause memleak. (com interfaces only!) }
  883. if result and Assigned(IEntry^.IID) and (IEntry^.IType in [etStandard, etFieldValue]) then
  884. IInterface(obj)._AddRef;
  885. end;
  886. function TObject.GetInterface(const iidstr : shortstring;out obj) : boolean;
  887. begin
  888. Result := GetInterfaceByStr(iidstr,obj);
  889. end;
  890. class function TObject.GetInterfaceEntry(const iid : tguid) : pinterfaceentry;
  891. var
  892. i: longint;
  893. intftable: pinterfacetable;
  894. ovmt: PVmt;
  895. begin
  896. ovmt := PVmt(Self);
  897. while Assigned(ovmt) and Assigned(ovmt^.vIntftable) do
  898. begin
  899. intftable:=ovmt^.vIntfTable;
  900. for i:=0 to intftable^.EntryCount-1 do
  901. begin
  902. result:=@intftable^.Entries[i];
  903. if assigned(Result^.iid) and IsGUIDEqual(Result^.iid^,iid) then
  904. Exit;
  905. end;
  906. ovmt := ovmt^.vParent;
  907. end;
  908. result := nil;
  909. end;
  910. class function TObject.GetInterfaceEntryByStr(const iidstr : shortstring) : pinterfaceentry;
  911. var
  912. i: longint;
  913. intftable: pinterfacetable;
  914. ovmt: PVmt;
  915. begin
  916. ovmt := PVmt(Self);
  917. while Assigned(ovmt) and Assigned(ovmt^.vIntfTable) do
  918. begin
  919. intftable:=ovmt^.vIntfTable;
  920. for i:=0 to intftable^.EntryCount-1 do
  921. begin
  922. result:=@intftable^.Entries[i];
  923. if assigned(result^.iidstr) and (result^.iidstr^ = iidstr) then
  924. Exit;
  925. end;
  926. ovmt := ovmt^.vParent;
  927. end;
  928. result:=nil;
  929. end;
  930. class function TObject.GetInterfaceTable : pinterfacetable;
  931. begin
  932. getinterfacetable:=PVmt(Self)^.vIntfTable;
  933. end;
  934. class procedure TObject.GetLastCastErrorInfo(out aFrom,aTo : shortstring);
  935. begin
  936. aFrom:=CastErrorFrom;
  937. aTo:=CastErrorTo;
  938. CastErrorFrom:='';
  939. CastErrorTo:='';
  940. end;
  941. class function TObject.UnitName : RTLString;
  942. {$ifdef FPC_HAS_FEATURE_RTTI}
  943. type
  944. TClassTypeInfo = {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
  945. Attributes: Pointer;
  946. case TTypeKind of
  947. tkClass: (
  948. ClassType: TClass;
  949. ParentInfo: Pointer;
  950. PropCount: SmallInt;
  951. UnitName: ShortString;
  952. );
  953. { include for proper alignment }
  954. tkInt64: (
  955. Dummy: Int64;
  956. );
  957. end;
  958. PClassTypeInfo = ^TClassTypeInfo;
  959. var
  960. classtypeinfo: PClassTypeInfo;
  961. begin
  962. classtypeinfo:=ClassInfo;
  963. if Assigned(classtypeinfo) then
  964. begin
  965. // offset PTypeInfo by Length(Name) + 2 (ShortString length byte + SizeOf(Kind))
  966. inc(Pointer(classtypeinfo), PByte(Pointer(classtypeinfo)+1)^ + 2);
  967. {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
  968. classtypeinfo:=aligntoqword(classtypeinfo);
  969. {$endif}
  970. result:=classtypeinfo^.UnitName;
  971. end
  972. else
  973. result:='';
  974. end;
  975. {$else not FPC_HAS_FEATURE_RTTI}
  976. begin
  977. result:='';
  978. end;
  979. {$endif ndef FPC_HAS_FEATURE_RTTI}
  980. class function TObject.QualifiedClassName: RTLString;
  981. var
  982. uname: RTLString;
  983. begin
  984. uname := UnitName; //TODO: change 'UnitName' to 'UnitScope' as soon as RTL implement it
  985. if uname='' then
  986. result:=ClassName
  987. else
  988. result:=Concat(uname, '.', ClassName);
  989. end;
  990. function TObject.Equals(Obj: TObject) : boolean;
  991. begin
  992. result:=Obj=Self;
  993. end;
  994. function TObject.GetHashCode: PtrInt;
  995. begin
  996. result:=PtrInt(Self);
  997. end;
  998. function TObject.ToString: RTLString;
  999. begin
  1000. result:=ClassName;
  1001. end;
  1002. procedure TObject.DisposeOf;
  1003. begin
  1004. Free;
  1005. end;
  1006. function TObject.GetDisposed : Boolean;
  1007. begin
  1008. Result:=False;
  1009. end;
  1010. procedure TObject.CheckDisposed;
  1011. begin
  1012. // Do nothing since we have no reference count.
  1013. end;
  1014. {$IFDEF SYSTEM_HAS_FEATURE_MONITOR}
  1015. function TObject.SetMonitorData(aData,aCheckOld : Pointer) : Pointer;
  1016. begin
  1017. Result:=InterlockedCompareExchange(_MonitorData,aData,aCheckOld);
  1018. end;
  1019. function TObject.GetMonitorData: Pointer;
  1020. begin
  1021. Result:=_MonitorData;
  1022. end;
  1023. {$ENDIF}
  1024. {****************************************************************************
  1025. TINTERFACEDOBJECT
  1026. ****************************************************************************}
  1027. function TInterfacedObject.QueryInterface(
  1028. {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  1029. begin
  1030. if getinterface(iid,obj) then
  1031. result:=S_OK
  1032. else
  1033. result:=longint(E_NOINTERFACE);
  1034. end;
  1035. function TInterfacedObject._AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  1036. begin
  1037. _addref:=frefcount;
  1038. if _addref<>0 then
  1039. begin
  1040. if _addref>0 then
  1041. _addref:=interlockedincrement(frefcount);
  1042. exit;
  1043. end;
  1044. frefcount:=1; { Work non-atomically in the common case of refcount = 0 (typical state after the complete object construction). }
  1045. _addref:=1;
  1046. end;
  1047. function TInterfacedObject._Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  1048. begin
  1049. _Release:=frefcount;
  1050. if _Release<>1 then
  1051. begin
  1052. if _Release<=0 then { -1 means recursive call from destructor... 0 is impossible. }
  1053. exit;
  1054. _Release:=interlockeddecrement(frefcount);
  1055. if _Release>0 then
  1056. exit;
  1057. end
  1058. else
  1059. _Release:=0; { Work non-atomically in the common case of refcount = 1 (typical state for the last owner... which is often the only owner). }
  1060. frefcount:=-1; { Prevent recursive _Release from destroying twice (bug 32168). }
  1061. self.destroy;
  1062. end;
  1063. destructor TInterfacedObject.Destroy;
  1064. begin
  1065. // We must explicitly reset. Bug ID 32353
  1066. FRefCount:=0;
  1067. inherited Destroy;
  1068. end;
  1069. procedure TInterfacedObject.AfterConstruction;
  1070. begin
  1071. { we need to fix the refcount we forced in newinstance }
  1072. { further, it must be done in a thread safe way }
  1073. if frefcount=1 then
  1074. frefcount:=0 { Work non-atomically in the common case of refcount = 1 (usual state before AfterConstruction). }
  1075. else
  1076. declocked(frefcount);
  1077. end;
  1078. procedure TInterfacedObject.BeforeDestruction;
  1079. begin
  1080. if frefcount>0 then { Legitimate values: -1 if destroying by _Release, 0 if destroying manually. }
  1081. HandleError(204);
  1082. end;
  1083. class function TInterfacedObject.NewInstance : TObject;
  1084. begin
  1085. NewInstance:=inherited NewInstance;
  1086. if NewInstance<>nil then
  1087. TInterfacedObject(NewInstance).frefcount:=1;
  1088. end;
  1089. {****************************************************************************
  1090. TAGGREGATEDOBJECT
  1091. ****************************************************************************}
  1092. constructor TAggregatedObject.Create(const aController: IUnknown);
  1093. begin
  1094. inherited Create;
  1095. { do not keep a counted reference to the controller! }
  1096. fcontroller := Pointer(aController);
  1097. end;
  1098. function TAggregatedObject.QueryInterface(
  1099. {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  1100. begin
  1101. Result := IUnknown(fcontroller).QueryInterface(iid, obj);
  1102. end;
  1103. function TAggregatedObject._AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  1104. begin
  1105. Result := IUnknown(fcontroller)._AddRef;
  1106. end;
  1107. function TAggregatedObject._Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  1108. begin
  1109. Result := IUnknown(fcontroller)._Release;
  1110. end;
  1111. function TAggregatedObject.GetController : IUnknown;
  1112. begin
  1113. Result := IUnknown(fcontroller);
  1114. end;
  1115. {****************************************************************************
  1116. TContainedOBJECT
  1117. ****************************************************************************}
  1118. function TContainedObject.QueryInterface(
  1119. {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  1120. begin
  1121. if getinterface(iid,obj) then
  1122. result:=S_OK
  1123. else
  1124. result:=longint(E_NOINTERFACE);
  1125. end;
  1126. {****************************************************************************
  1127. TNoRefCountObject
  1128. ****************************************************************************}
  1129. function TNoRefCountObject.QueryInterface( {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  1130. begin
  1131. if getinterface(iid,obj) then
  1132. result:=S_OK
  1133. else
  1134. result:=longint(E_NOINTERFACE);
  1135. end;
  1136. function TNoRefCountObject._AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  1137. begin
  1138. Result:=-1;
  1139. end;
  1140. function TNoRefCountObject._Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  1141. begin
  1142. Result:=-1;
  1143. end;
  1144. {****************************************************************************
  1145. TCustomAttribute
  1146. ****************************************************************************}
  1147. constructor TCustomAttribute.Create;
  1148. begin
  1149. inherited;
  1150. end;
  1151. {****************************************************************************
  1152. TUnimplementedAttribute
  1153. ****************************************************************************}
  1154. constructor TUnimplementedAttribute.Create;
  1155. begin
  1156. inherited;
  1157. end;
  1158. {****************************************************************************
  1159. TCustomStoredAttribute
  1160. ****************************************************************************}
  1161. constructor StoredAttribute.Create;
  1162. begin
  1163. end;
  1164. constructor StoredAttribute.Create(Const aFlag : Boolean);
  1165. begin
  1166. FFlag:=aFlag;
  1167. end;
  1168. constructor StoredAttribute.Create(Const aName : shortstring);
  1169. begin
  1170. FName:=aName;
  1171. end;
  1172. {****************************************************************************
  1173. TInterfaceThunk
  1174. ****************************************************************************}
  1175. Constructor TInterfaceThunk.Create(aCallback : TThunkCallback);
  1176. begin
  1177. FCallBack:=aCallBack;
  1178. end;
  1179. Procedure TInterfaceThunk.Thunk(aMethod: Longint; aCount : Longint; aData : PArgData);
  1180. begin
  1181. if Assigned(FCallBack) then
  1182. FCallBack(Self,aMethod,aCount,aData);
  1183. end;
  1184. function TInterfaceThunk.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  1185. begin
  1186. result:=longint(E_NOINTERFACE);
  1187. if (TMethod(FCallBack).Data<>Nil) then
  1188. // Query the object that created us, this is normally TVirtualInterface
  1189. // Take care: do not call QueryInterface, that would create a never-ending loop !!
  1190. if TObject(TMethod(FCallBack).Data).GetInterface(iid,obj) then
  1191. result:=S_OK;
  1192. if (Result<>S_OK) then
  1193. Result:=Inherited QueryInterface(iid,obj);
  1194. if (Result<>S_OK) and Assigned(OnQueryInterface) then
  1195. OnQueryInterface(iid,Result,obj);
  1196. end;
  1197. function TInterfaceThunk.InterfaceVMTOffset : word;
  1198. begin
  1199. Result:=0;
  1200. end;
  1201. {****************************************************************************
  1202. Exception Support
  1203. ****************************************************************************}
  1204. {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  1205. {$if defined(FPC_WASM_EXNREF_EXCEPTIONS)}
  1206. {$I except_exnref.inc}
  1207. {$elseif defined(FPC_WASM_LEGACY_EXCEPTIONS)}
  1208. {$I except_legacy.inc}
  1209. {$elseif defined(FPC_WASM_BRANCHFUL_EXCEPTIONS)}
  1210. {$I except_branchful.inc}
  1211. {$else}
  1212. {$i except.inc}
  1213. {$endif}
  1214. {$endif FPC_HAS_FEATURE_EXCEPTIONS}
  1215. {****************************************************************************
  1216. Various Delphi constructs
  1217. ****************************************************************************}
  1218. class operator TMethod.=(const aLeft, aRight: TMethod): Boolean; inline;
  1219. begin
  1220. Result:=(aLeft.Data=aRight.Data) and (aLeft.Code=aRight.Code);
  1221. end;
  1222. class operator TMethod.<>(const aLeft, aRight: TMethod): Boolean; inline;
  1223. begin
  1224. Result:=(aLeft.Data<>aRight.Data) or (aLeft.Code<>aRight.Code);
  1225. end;
  1226. class operator TMethod.>(const aLeft, aRight: TMethod): Boolean; inline;
  1227. begin
  1228. Result:=(PtrUInt(aLeft.Data)>PtrUInt(aRight.Data))
  1229. or
  1230. ((aLeft.Data=aRight.Data) and (PtrUInt(aLeft.Code)>PtrUint(aRight.Code)));
  1231. end;
  1232. class operator TMethod.>=(const aLeft, aRight: TMethod): Boolean; inline;
  1233. begin
  1234. Result:=(aLeft>aRight) or (aLeft=aRight);
  1235. end;
  1236. class operator TMethod.<(const aLeft, aRight: TMethod): Boolean; inline;
  1237. begin
  1238. Result:=(PtrUInt(aLeft.Data)<PtrUInt(aRight.Data))
  1239. or
  1240. ((aLeft.Data=aRight.Data) and (PtrUInt(aLeft.Code)<PtrUint(aRight.Code)));
  1241. end;
  1242. class operator TMethod.<=(const aLeft, aRight: TMethod): Boolean; inline;
  1243. begin
  1244. Result:=(aLeft<aRight) or (aLeft=aRight);
  1245. end;
  1246. function TPtrWrapper.ToPointer: Pointer;
  1247. begin
  1248. Result:=FValue;
  1249. end;
  1250. class function TPtrWrapper.GetNilValue: TPtrWrapper;
  1251. begin
  1252. Result.FValue:=Nil;
  1253. end;
  1254. constructor TPtrWrapper.Create(AValue: PtrInt);
  1255. begin
  1256. FValue:=Pointer(aValue);
  1257. end;
  1258. constructor TPtrWrapper.Create(AValue: Pointer);
  1259. begin
  1260. FValue:=aValue;
  1261. end;
  1262. function TPtrWrapper.ToInteger: PtrInt;
  1263. begin
  1264. Result:=PtrInt(FValue);
  1265. end;
  1266. class operator TPtrWrapper.=(Left, Right: TPtrWrapper): Boolean;
  1267. begin
  1268. Result:=Left.FValue=Right.FValue;
  1269. end;
  1270. constructor TMarshal.Create;
  1271. begin
  1272. System.Error(reInvalidPtr);
  1273. end;
  1274. class function TMarshal.AllocMem(Size: SizeInt): TPtrWrapper;
  1275. begin
  1276. Result.Value := System.AllocMem(Size);
  1277. end;
  1278. class function TMarshal.ReallocMem(OldPtr: TPtrWrapper; NewSize: SizeInt): TPtrWrapper;
  1279. var
  1280. P: Pointer;
  1281. begin
  1282. P := OldPtr.Value;
  1283. Result.Value := System.ReallocMem(P, NewSize);
  1284. end;
  1285. class procedure TMarshal.FreeMem(Ptr: TPtrWrapper);
  1286. begin
  1287. System.FreeMem(Ptr.Value);
  1288. end;
  1289. class procedure TMarshal.Move(Src, Dest: TPtrWrapper; Count: SizeInt); static;
  1290. begin
  1291. System.Move(Src.Value^, Dest.Value^, Count);
  1292. end;
  1293. class function TMarshal.UnsafeAddrOf(var Value): TPtrWrapper;
  1294. begin
  1295. Result.Value := @Value;
  1296. end;
  1297. class procedure TMarshal.Copy(const Src: TUint8Array; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
  1298. begin
  1299. System.Move(PUInt8(Src)[StartIndex], Dest.Value^, Count * SizeOf(UInt8));
  1300. end;
  1301. class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TUint8Array; StartIndex: SizeInt; Count: SizeInt);
  1302. begin
  1303. System.Move(Src.Value^, PUInt8(Dest)[StartIndex], Count * SizeOf(UInt8));
  1304. end;
  1305. class procedure TMarshal.Copy(const Src: TInt8Array; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
  1306. begin
  1307. System.Move(PInt8(Src)[StartIndex], Dest.Value^, Count * SizeOf(Int8));
  1308. end;
  1309. class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TInt8Array ; StartIndex: SizeInt; Count: SizeInt);
  1310. begin
  1311. System.Move(Src.Value^, PInt8(Dest)[StartIndex], Count * SizeOf(Int8));
  1312. end;
  1313. class procedure TMarshal.Copy(const Src: TUInt16Array; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
  1314. begin
  1315. System.Move(PUInt16(Src)[StartIndex], Dest.Value^, Count * SizeOf(UInt16));
  1316. end;
  1317. class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TUint16Array; StartIndex: SizeInt; Count: SizeInt);
  1318. begin
  1319. System.Move(Src.Value^, PUInt16(Dest)[StartIndex], Count * SizeOf(UInt16));
  1320. end;
  1321. class procedure TMarshal.Copy(const Src: TInt16Array; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
  1322. begin
  1323. System.Move(PInt16(Src)[StartIndex], Dest.Value^, Count * SizeOf(Int16));
  1324. end;
  1325. class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TInt16Array; StartIndex: SizeInt; Count: SizeInt);
  1326. begin
  1327. System.Move(Src.Value^, PInt16(Dest)[StartIndex], Count * SizeOf(Int16));
  1328. end;
  1329. class procedure TMarshal.Copy(const Src: TInt32Array; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
  1330. begin
  1331. System.Move(PInt32(Src)[StartIndex], Dest.Value^, Count * SizeOf(Int32));
  1332. end;
  1333. class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TInt32Array; StartIndex: SizeInt; Count: SizeInt);
  1334. begin
  1335. System.Move(Src.Value^, PInt32(Dest)[StartIndex], Count * SizeOf(Int32));
  1336. end;
  1337. class procedure TMarshal.Copy(const Src: TInt64Array; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
  1338. begin
  1339. System.Move(PInt64(Src)[StartIndex], Dest.Value^, Count * SizeOf(Int64));
  1340. end;
  1341. class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TInt64Array; StartIndex: SizeInt; Count: SizeInt);
  1342. begin
  1343. System.Move(Src.Value^, PInt64(Dest)[StartIndex], Count * SizeOf(Int64));
  1344. end;
  1345. class procedure TMarshal.Copy(const Src: TPtrWrapperArray; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
  1346. begin
  1347. System.Move(PPointer(Src)[StartIndex], Dest.Value^, Count * SizeOf(TPtrWrapper));
  1348. end;
  1349. class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TPtrWrapperArray; StartIndex: SizeInt; Count: SizeInt);
  1350. begin
  1351. System.Move(Src.Value^, PPointer(Dest)[StartIndex], Count * SizeOf(TPtrWrapper));
  1352. end;
  1353. generic class function TMarshal.FixArray<T>(const Arr: specialize TArray<T>): TPtrWrapper;
  1354. begin
  1355. Result.Value := nil;
  1356. specialize TArray<T>(Result) := Arr;
  1357. end;
  1358. generic class procedure TMarshal.UnfixArray<T>(ArrPtr: TPtrWrapper);
  1359. begin
  1360. Finalize(specialize TArray<T>(ArrPtr));
  1361. end;
  1362. class function TMarshal.ReadByte(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Byte;
  1363. begin
  1364. Result := PByte(Ptr.Value + Ofs)^;
  1365. end;
  1366. class procedure TMarshal.WriteByte(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Byte);
  1367. begin
  1368. PByte(Ptr.Value + Ofs)^ := Value;
  1369. end;
  1370. class procedure TMarshal.WriteByte(Ptr: TPtrWrapper; Value: Byte);
  1371. begin
  1372. PByte(Ptr.Value)^ := Value;
  1373. end;
  1374. class function TMarshal.ReadInt16(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Int16;
  1375. begin
  1376. Result := PInt16(Ptr.Value + Ofs)^;
  1377. end;
  1378. class procedure TMarshal.WriteInt16(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Int16);
  1379. begin
  1380. PInt16(Ptr.Value + Ofs)^ := Value;
  1381. end;
  1382. class procedure TMarshal.WriteInt16(Ptr: TPtrWrapper; Value: Int16);
  1383. begin
  1384. PInt16(Ptr.Value)^ := Value;
  1385. end;
  1386. class function TMarshal.ReadInt32(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Int32;
  1387. begin
  1388. Result := PInt32(Ptr.Value + Ofs)^;
  1389. end;
  1390. class procedure TMarshal.WriteInt32(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Int32);
  1391. begin
  1392. PInt32(Ptr.Value + Ofs)^ := Value;
  1393. end;
  1394. class procedure TMarshal.WriteInt32(Ptr: TPtrWrapper; Value: Int32);
  1395. begin
  1396. PInt32(Ptr.Value)^ := Value;
  1397. end;
  1398. class function TMarshal.ReadInt64(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Int64;
  1399. begin
  1400. Result := PInt64(Ptr.Value + Ofs)^;
  1401. end;
  1402. class procedure TMarshal.WriteInt64(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Int64);
  1403. begin
  1404. PInt64(Ptr.Value + Ofs)^ := Value;
  1405. end;
  1406. class procedure TMarshal.WriteInt64(Ptr: TPtrWrapper; Value: Int64);
  1407. begin
  1408. PInt64(Ptr.Value)^ := Value;
  1409. end;
  1410. class function TMarshal.ReadPtr(Ptr: TPtrWrapper; Ofs: SizeInt = 0): TPtrWrapper;
  1411. begin
  1412. Result.Value := PPointer(Ptr.Value + Ofs)^;
  1413. end;
  1414. class procedure TMarshal.WritePtr(Ptr: TPtrWrapper; Ofs: SizeInt; Value: TPtrWrapper);
  1415. begin
  1416. PPointer(Ptr.Value + Ofs)^ := Value.Value;
  1417. end;
  1418. class procedure TMarshal.WritePtr(Ptr, Value: TPtrWrapper);
  1419. begin
  1420. PPointer(Ptr.Value)^ := Value.Value;
  1421. end;
  1422. {$IFDEF FPC_HAS_FEATURE_UNICODESTRINGS}
  1423. class function TMarshal.AsAnsi(const S: UnicodeString): AnsiString;
  1424. begin
  1425. Result := AnsiString(S);
  1426. end;
  1427. class function TMarshal.AsAnsi(S: PUnicodeChar): AnsiString;
  1428. begin
  1429. result := AnsiString(S);
  1430. end;
  1431. class function TMarshal.InOutString(const S: UnicodeString): PUnicodeChar;
  1432. begin
  1433. Result := PUnicodeChar(S);
  1434. end;
  1435. class function TMarshal.InString(const S: UnicodeString): PUnicodeChar;
  1436. begin
  1437. Result := PUnicodeChar(S);
  1438. end;
  1439. class function TMarshal.OutString(const S: UnicodeString): PUnicodeChar;
  1440. begin
  1441. Result := PUnicodeChar(S);
  1442. end;
  1443. class function TMarshal.FixString(var Str: UnicodeString): TPtrWrapper;
  1444. begin
  1445. UniqueString(Str);
  1446. Result := UnsafeFixString(Str);
  1447. end;
  1448. class procedure TMarshal.UnfixString(Ptr: TPtrWrapper);
  1449. begin
  1450. if Ptr.Value <> PUnicodeChar('') then
  1451. Finalize(UnicodeString(Ptr));
  1452. end;
  1453. class function TMarshal.UnsafeFixString(const Str: UnicodeString): TPtrWrapper;
  1454. begin
  1455. if Length(Str) = 0 then
  1456. begin
  1457. Result.Value := PUnicodeChar('');
  1458. Exit;
  1459. end;
  1460. Result.Value := nil;
  1461. UnicodeString(Result) := Str;
  1462. end;
  1463. class function TMarshal.AllocStringAsAnsi(const Str: UnicodeString): TPtrWrapper;
  1464. begin
  1465. Result := AllocStringAsAnsi(PUnicodeChar(Pointer(Str)), Length(Str), DefaultSystemCodePage);
  1466. end;
  1467. class function TMarshal.AllocStringAsAnsi(const Str: UnicodeString; CodePage: Word): TPtrWrapper;
  1468. begin
  1469. Result := AllocStringAsAnsi(PUnicodeChar(Pointer(Str)), Length(Str), CodePage);
  1470. end;
  1471. class function TMarshal.AllocStringAsAnsi(S: PUnicodeChar): TPtrWrapper;
  1472. begin
  1473. Result := AllocStringAsAnsi(S, Length(S), DefaultSystemCodePage);
  1474. end;
  1475. class function TMarshal.AllocStringAsAnsi(S: PUnicodeChar; CodePage: Word): TPtrWrapper;
  1476. begin
  1477. Result := AllocStringAsAnsi(S, Length(S), CodePage);
  1478. end;
  1479. class function TMarshal.AllocStringAsUnicode(const Str: UnicodeString): TPtrWrapper;
  1480. var
  1481. NBytes: SizeUint;
  1482. begin
  1483. NBytes := (Length(Str) + 1) * SizeOf(UnicodeChar);
  1484. Result.Value := System.GetMem(NBytes);
  1485. System.Move(PUnicodeChar(Str)^, Result.Value^, NBytes);
  1486. end;
  1487. class function TMarshal.AllocStringAsUtf8(const Str: UnicodeString): TPtrWrapper;
  1488. begin
  1489. Result := AllocStringAsAnsi(PUnicodeChar(Pointer(Str)), Length(Str), CP_UTF8);
  1490. end;
  1491. class function TMarshal.AllocStringAsUtf8(S: PUnicodeChar): TPtrWrapper;
  1492. begin
  1493. Result := AllocStringAsAnsi(S, Length(S), CP_UTF8);
  1494. end;
  1495. class function TMarshal.AllocStringAsAnsi(S: PUnicodeChar; Len: SizeInt; CodePage: Word): TPtrWrapper;
  1496. var
  1497. U2ARes: AnsiString;
  1498. NBytes: SizeInt;
  1499. begin
  1500. U2ARes := ''; { Suppress warning. }
  1501. WideStringManager.Unicode2AnsiMoveProc(S, U2ARes, CodePage, Len);
  1502. if Length(U2ARes) = 0 then
  1503. begin
  1504. Result.Value := nil;
  1505. Exit;
  1506. end;
  1507. { Could instead avoid the second allocation, assuming U2ARes.RefCount = 1:
  1508. System.Move(Pointer(U2ARes)^, (Pointer(U2ARes) - AnsiStringHeaderSize)^, (Length(U2ARes) + 1) * SizeOf(AnsiChar));
  1509. Result.FValue := Pointer(U2ARes) - AnsiStringHeaderSize;
  1510. Pointer(U2ARes) := nil; }
  1511. NBytes := (Length(U2ARes) + 1) * SizeOf(AnsiChar);
  1512. Result.Value := System.GetMem(NBytes);
  1513. System.Move(PAnsiChar(U2ARes)^, Result.Value^, NBytes);
  1514. end;
  1515. class procedure TMarshal.Copy(const Src: TUnicodeCharArray; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
  1516. begin
  1517. System.Move(PUnicodeChar(Src)[StartIndex], Dest.Value^, Count * SizeOf(UnicodeChar));
  1518. end;
  1519. class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TUnicodeCharArray; StartIndex: SizeInt; Count: SizeInt);
  1520. begin
  1521. System.Move(Src.Value^, PUnicodeChar(Dest)[StartIndex], Count * SizeOf(UnicodeChar));
  1522. end;
  1523. class function TMarshal.ReadStringAsAnsi(Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString;
  1524. begin
  1525. Result := ReadStringAsAnsi(DefaultSystemCodePage, Ptr, Len);
  1526. end;
  1527. class function TMarshal.ReadStringAsAnsi(CodePage: Word; Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString;
  1528. begin
  1529. { Here and below, IndexByte/Word assume that, when Len >= 0, either:
  1530. - Up to Len characters are accessible in Ptr;
  1531. - IndexByte/Word cannot access invalid memory past the searched character
  1532. (e.g. i386.inc and x86_64.inc IndexByte/Word versions are specifically designed not to). }
  1533. if Len < 0 then
  1534. Len := IndexByte(Ptr.Value^, Len, 0);
  1535. Result := ''; { Suppress warning. }
  1536. WideStringManager.Ansi2UnicodeMoveProc(Ptr.Value, CodePage, Result, Len);
  1537. end;
  1538. class function TMarshal.ReadStringAsAnsiUpTo(CodePage: Word; Ptr: TPtrWrapper; MaxLen: SizeInt): UnicodeString;
  1539. var
  1540. Len: SizeInt;
  1541. begin
  1542. Len := IndexByte(Ptr.Value^, MaxLen, 0);
  1543. if Len < 0 then
  1544. Len := MaxLen;
  1545. Result := ReadStringAsAnsi(CodePage, Ptr, Len);
  1546. end;
  1547. class procedure TMarshal.WriteStringAsAnsi(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
  1548. begin
  1549. WriteStringAsAnsi(Ptr, 0, Value, MaxCharsIncNull, DefaultSystemCodePage);
  1550. end;
  1551. class procedure TMarshal.WriteStringAsAnsi(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt; CodePage: Word);
  1552. begin
  1553. WriteStringAsAnsi(Ptr, 0, Value, MaxCharsIncNull, CodePage);
  1554. end;
  1555. class procedure TMarshal.WriteStringAsAnsi(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
  1556. begin
  1557. WriteStringAsAnsi(Ptr, Ofs, Value, MaxCharsIncNull, DefaultSystemCodePage);
  1558. end;
  1559. class procedure TMarshal.WriteStringAsAnsi(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt; CodePage: Word);
  1560. var
  1561. U2ARes: AnsiString;
  1562. ValueLen, U2AResLen: SizeInt;
  1563. begin
  1564. U2ARes := ''; { Suppress warning. }
  1565. ValueLen := Length(Value);
  1566. { Delphi null-terminates iff MaxCharsIncNull < 0, so MaxCharsIncNull is actually just MaxChars. }
  1567. if (MaxCharsIncNull > 0) and (MaxCharsIncNull < ValueLen) then
  1568. ValueLen := MaxCharsIncNull; { UTF-16 → ANSI should never shrink element count, so limit the number of characters analyzed. }
  1569. WideStringManager.Unicode2AnsiMoveProc(PUnicodeChar(Pointer(Value)), U2ARes, CodePage, ValueLen);
  1570. U2AResLen := Length(U2ARes);
  1571. if (MaxCharsIncNull >= 0) and (MaxCharsIncNull < U2AResLen) then
  1572. U2AResLen := MaxCharsIncNull;
  1573. System.Move(PAnsiChar(Pointer(U2ARes))^, (Ptr.Value + Ofs)^, U2AResLen * SizeOf(AnsiChar));
  1574. if MaxCharsIncNull < 0 then
  1575. PAnsiChar(Ptr.Value + Ofs)[U2AResLen] := #0;
  1576. end;
  1577. class function TMarshal.ReadStringAsUnicode(Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString;
  1578. begin
  1579. if Len < 0 then
  1580. Len := Length(PUnicodeChar(Ptr.Value));
  1581. Result := ''; { Suppress warning. }
  1582. SetLength(Result, Len);
  1583. System.Move(Ptr.Value^, Pointer(Result)^, Len * SizeOf(UnicodeChar));
  1584. end;
  1585. class function TMarshal.ReadStringAsUnicodeUpTo(Ptr: TPtrWrapper; MaxLen: SizeInt): UnicodeString;
  1586. var
  1587. Len: SizeInt;
  1588. begin
  1589. Len := IndexWord(Ptr.Value^, MaxLen, 0);
  1590. if Len < 0 then
  1591. Len := MaxLen;
  1592. Result := ReadStringAsUnicode(Ptr, Len);
  1593. end;
  1594. class procedure TMarshal.WriteStringAsUnicode(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
  1595. begin
  1596. WriteStringAsUnicode(Ptr, 0, Value, MaxCharsIncNull);
  1597. end;
  1598. class procedure TMarshal.WriteStringAsUnicode(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
  1599. var
  1600. Len: SizeInt;
  1601. begin
  1602. { Again, Delphi null-terminates iff MaxCharsIncNull < 0, so MaxCharsIncNull is actually just MaxChars. }
  1603. Len := Length(Value);
  1604. if (MaxCharsIncNull >= 0) and (MaxCharsIncNull < Len) then
  1605. Len := MaxCharsIncNull;
  1606. System.Move(Pointer(Value)^, (Ptr.Value + Ofs)^, Len * SizeOf(UnicodeChar));
  1607. if MaxCharsIncNull < 0 then
  1608. PUnicodeChar(Ptr.Value + Ofs)[Len] := #0;
  1609. end;
  1610. class function TMarshal.ReadStringAsUtf8(Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString;
  1611. begin
  1612. Result := ReadStringAsAnsi(CP_UTF8, Ptr, Len);
  1613. end;
  1614. class function TMarshal.ReadStringAsUtf8UpTo(Ptr: TPtrWrapper; MaxLen: SizeInt): UnicodeString;
  1615. begin
  1616. Result := ReadStringAsAnsiUpTo(CP_UTF8, Ptr, MaxLen);
  1617. end;
  1618. class procedure TMarshal.WriteStringAsUtf8(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
  1619. begin
  1620. WriteStringAsAnsi(Ptr, Value, MaxCharsIncNull, CP_UTF8);
  1621. end;
  1622. class procedure TMarshal.WriteStringAsUtf8(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
  1623. begin
  1624. WriteStringAsAnsi(Ptr, Ofs, Value, MaxCharsIncNull, CP_UTF8);
  1625. end;
  1626. {$ENDIF}
  1627. {$IFDEF SYSTEM_HAS_FEATURE_MONITOR}
  1628. {$i monitor.inc}
  1629. {$ENDIF}