writer.inc 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855
  1. {
  2. $Id$
  3. This file is part of the Free Component Library (FCL)
  4. Copyright (c) 1999-2000 by the Free Pascal development team
  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. {****************************************************************************}
  12. {* TBinaryObjectWriter *}
  13. {****************************************************************************}
  14. constructor TBinaryObjectWriter.Create(Stream: TStream; BufSize: Integer);
  15. begin
  16. inherited Create;
  17. FStream := Stream;
  18. FBufSize := BufSize;
  19. GetMem(FBuffer, BufSize);
  20. end;
  21. destructor TBinaryObjectWriter.Destroy;
  22. begin
  23. // Flush all data which hasn't been written yet
  24. FlushBuffer;
  25. if Assigned(FBuffer) then
  26. FreeMem(FBuffer, FBufSize);
  27. inherited Destroy;
  28. end;
  29. procedure TBinaryObjectWriter.BeginCollection;
  30. begin
  31. WriteValue(vaCollection);
  32. end;
  33. procedure TBinaryObjectWriter.BeginComponent(Component: TComponent;
  34. Flags: TFilerFlags; ChildPos: Integer);
  35. var
  36. Prefix: Byte;
  37. begin
  38. if not FSignatureWritten then
  39. begin
  40. Write(FilerSignature, SizeOf(FilerSignature));
  41. FSignatureWritten := True;
  42. end;
  43. { Only write the flags if they are needed! }
  44. if Flags <> [] then
  45. begin
  46. Prefix := Integer(Flags) or $f0;
  47. Write(Prefix, 1);
  48. if ffChildPos in Flags then
  49. WriteInteger(ChildPos);
  50. end;
  51. WriteStr(Component.ClassName);
  52. WriteStr(Component.Name);
  53. end;
  54. procedure TBinaryObjectWriter.BeginList;
  55. begin
  56. WriteValue(vaList);
  57. end;
  58. procedure TBinaryObjectWriter.EndList;
  59. begin
  60. WriteValue(vaNull);
  61. end;
  62. procedure TBinaryObjectWriter.BeginProperty(const PropName: String);
  63. begin
  64. WriteStr(PropName);
  65. end;
  66. procedure TBinaryObjectWriter.EndProperty;
  67. begin
  68. end;
  69. procedure TBinaryObjectWriter.WriteBinary(const Buffer; Count: LongInt);
  70. begin
  71. WriteValue(vaBinary);
  72. Write(Count, 4);
  73. Write(Buffer, Count);
  74. end;
  75. procedure TBinaryObjectWriter.WriteBoolean(Value: Boolean);
  76. begin
  77. if Value then
  78. WriteValue(vaTrue)
  79. else
  80. WriteValue(vaFalse);
  81. end;
  82. procedure TBinaryObjectWriter.WriteFloat(const Value: Extended);
  83. begin
  84. WriteValue(vaExtended);
  85. Write(Value, SizeOf(Value));
  86. end;
  87. procedure TBinaryObjectWriter.WriteSingle(const Value: Single);
  88. begin
  89. WriteValue(vaSingle);
  90. Write(Value, SizeOf(Value));
  91. end;
  92. {!!!: procedure TBinaryObjectWriter.WriteCurrency(const Value: Currency);
  93. begin
  94. WriteValue(vaCurrency);
  95. Write(Value, SizeOf(Value));
  96. end;}
  97. procedure TBinaryObjectWriter.WriteDate(const Value: TDateTime);
  98. begin
  99. WriteValue(vaDate);
  100. Write(Value, SizeOf(Value));
  101. end;
  102. procedure TBinaryObjectWriter.WriteIdent(const Ident: string);
  103. begin
  104. { Check if Ident is a special identifier before trying to just write
  105. Ident directly }
  106. if UpperCase(Ident) = 'NIL' then
  107. WriteValue(vaNil)
  108. else if UpperCase(Ident) = 'FALSE' then
  109. WriteValue(vaFalse)
  110. else if UpperCase(Ident) = 'TRUE' then
  111. WriteValue(vaTrue)
  112. else if UpperCase(Ident) = 'NULL' then
  113. WriteValue(vaNull) else
  114. begin
  115. WriteValue(vaIdent);
  116. WriteStr(Ident);
  117. end;
  118. end;
  119. procedure TBinaryObjectWriter.WriteInteger(Value: Int64);
  120. begin
  121. { Use the smallest possible integer type for the given value: }
  122. if (Value >= -128) and (Value <= 127) then
  123. begin
  124. WriteValue(vaInt8);
  125. Write(Value, 1);
  126. end else if (Value >= -32768) and (Value <= 32767) then
  127. begin
  128. WriteValue(vaInt16);
  129. Write(Value, 2);
  130. end else if (Value >= -$80000000) and (Value <= $7fffffff) then
  131. begin
  132. WriteValue(vaInt32);
  133. Write(Value, 4);
  134. end else
  135. begin
  136. WriteValue(vaInt64);
  137. Write(Value, 8);
  138. end;
  139. end;
  140. procedure TBinaryObjectWriter.WriteMethodName(const Name: String);
  141. begin
  142. if Length(Name) > 0 then
  143. begin
  144. WriteValue(vaIdent);
  145. WriteStr(Name);
  146. end else
  147. WriteValue(vaNil);
  148. end;
  149. procedure TBinaryObjectWriter.WriteSet(Value: LongInt; SetType: Pointer);
  150. var
  151. i: Integer;
  152. Mask: LongInt;
  153. begin
  154. WriteValue(vaSet);
  155. Mask := 1;
  156. for i := 0 to 31 do
  157. begin
  158. if (Value and Mask) <> 0 then
  159. WriteStr(GetEnumName(PTypeInfo(SetType), i));
  160. Mask := Mask shl 1;
  161. end;
  162. WriteStr('');
  163. end;
  164. procedure TBinaryObjectWriter.WriteString(const Value: String);
  165. var
  166. i: Integer;
  167. begin
  168. i := Length(Value);
  169. if i <= 255 then
  170. begin
  171. WriteValue(vaString);
  172. Write(i, 1);
  173. end else
  174. begin
  175. WriteValue(vaLString);
  176. Write(i, 4);
  177. end;
  178. if i > 0 then
  179. Write(Value[1], i);
  180. end;
  181. {!!!: procedure TBinaryObjectWriter.WriteWideString(const Value: WideString);
  182. var
  183. i: Integer;
  184. begin
  185. WriteValue(vaWString);
  186. i := Length(Value);
  187. Write(i, 4);
  188. Write(Value[1], i * 2);
  189. end;}
  190. procedure TBinaryObjectWriter.FlushBuffer;
  191. begin
  192. FStream.WriteBuffer(FBuffer^, FBufPos);
  193. FBufPos := 0;
  194. end;
  195. procedure TBinaryObjectWriter.Write(const Buffer; Count: LongInt);
  196. var
  197. CopyNow: LongInt;
  198. SourceBuf: PChar;
  199. begin
  200. SourceBuf:=@Buffer;
  201. while Count > 0 do
  202. begin
  203. CopyNow := Count;
  204. if CopyNow > FBufSize - FBufPos then
  205. CopyNow := FBufSize - FBufPos;
  206. Move(SourceBuf^, PChar(FBuffer)[FBufPos], CopyNow);
  207. Dec(Count, CopyNow);
  208. Inc(FBufPos, CopyNow);
  209. inc(SourceBuf, CopyNow);
  210. if FBufPos = FBufSize then
  211. FlushBuffer;
  212. end;
  213. end;
  214. procedure TBinaryObjectWriter.WriteValue(Value: TValueType);
  215. begin
  216. Write(Value, 1);
  217. end;
  218. procedure TBinaryObjectWriter.WriteStr(const Value: String);
  219. var
  220. i: Integer;
  221. begin
  222. i := Length(Value);
  223. if i > 255 then
  224. i := 255;
  225. Write(i, 1);
  226. if i > 0 then
  227. Write(Value[1], i);
  228. end;
  229. {****************************************************************************}
  230. {* TWriter *}
  231. {****************************************************************************}
  232. constructor TWriter.Create(ADriver: TAbstractObjectWriter);
  233. begin
  234. inherited Create;
  235. FDriver := ADriver;
  236. end;
  237. constructor TWriter.Create(Stream: TStream; BufSize: Integer);
  238. begin
  239. inherited Create;
  240. FDriver := TBinaryObjectWriter.Create(Stream, BufSize);
  241. FDestroyDriver := True;
  242. end;
  243. destructor TWriter.Destroy;
  244. begin
  245. if FDestroyDriver then
  246. FDriver.Free;
  247. inherited Destroy;
  248. end;
  249. // Used as argument for calls to TComponent.GetChildren:
  250. procedure TWriter.AddToAncestorList(Component: TComponent);
  251. begin
  252. FAncestorList.Add(Component);
  253. end;
  254. procedure TWriter.DefineProperty(const Name: String;
  255. ReadData: TReaderProc; AWriteData: TWriterProc; HasData: Boolean);
  256. begin
  257. if HasData and Assigned(AWriteData) then
  258. begin
  259. // Write the property name and then the data itself
  260. Driver.BeginProperty(FPropPath + Name);
  261. AWriteData(Self);
  262. Driver.EndProperty;
  263. end;
  264. end;
  265. procedure TWriter.DefineBinaryProperty(const Name: String;
  266. ReadData, AWriteData: TStreamProc; HasData: Boolean);
  267. begin
  268. if HasData and Assigned(AWriteData) then
  269. begin
  270. // Write the property name and then the data itself
  271. Driver.BeginProperty(FPropPath + Name);
  272. WriteBinary(AWriteData);
  273. Driver.EndProperty;
  274. end;
  275. end;
  276. procedure TWriter.SetRoot(ARoot: TComponent);
  277. begin
  278. inherited SetRoot(ARoot);
  279. // Use the new root as lookup root too
  280. FLookupRoot := ARoot;
  281. end;
  282. procedure TWriter.WriteBinary(AWriteData: TStreamProc);
  283. var
  284. MemBuffer: TMemoryStream;
  285. BufferSize: Longint;
  286. begin
  287. { First write the binary data into a memory stream, then copy this buffered
  288. stream into the writing destination. This is necessary as we have to know
  289. the size of the binary data in advance (we're assuming that seeking within
  290. the writer stream is not possible) }
  291. MemBuffer := TMemoryStream.Create;
  292. try
  293. AWriteData(MemBuffer);
  294. BufferSize := MemBuffer.Size;
  295. Driver.WriteBinary(MemBuffer.Memory^, BufferSize);
  296. finally
  297. MemBuffer.Free;
  298. end;
  299. end;
  300. procedure TWriter.WriteBoolean(Value: Boolean);
  301. begin
  302. Driver.WriteBoolean(Value);
  303. end;
  304. procedure TWriter.WriteChar(Value: Char);
  305. begin
  306. WriteString(Value);
  307. end;
  308. procedure TWriter.WriteCollection(Value: TCollection);
  309. var
  310. i: Integer;
  311. begin
  312. Driver.BeginCollection;
  313. if Assigned(Value) then
  314. for i := 0 to Value.Count - 1 do
  315. begin
  316. { Each collection item needs its own ListBegin/ListEnd tag, or else the
  317. reader wouldn't be able to know where an item ends and where the next
  318. one starts }
  319. WriteListBegin;
  320. WriteProperties(Value.Items[i]);
  321. WriteListEnd;
  322. end;
  323. WriteListEnd;
  324. end;
  325. procedure TWriter.WriteComponent(Component: TComponent);
  326. var
  327. SavedAncestor: TPersistent;
  328. SavedRootAncestor, AncestorComponent, CurAncestor: TComponent;
  329. i: Integer;
  330. s: String;
  331. begin
  332. SavedAncestor := Ancestor;
  333. SavedRootAncestor := RootAncestor;
  334. try
  335. // The component has to know that it is being written now...
  336. Include(Component.FComponentState, csWriting);
  337. // Locate the component in the ancestor list, if necessary
  338. if Assigned(FAncestorList) then
  339. begin
  340. Ancestor := nil;
  341. s := UpperCase(Component.Name);
  342. for i := 0 to FAncestorList.Count - 1 do
  343. begin
  344. CurAncestor := TComponent(FAncestorList[i]);
  345. if UpperCase(CurAncestor.Name) = s then
  346. begin
  347. Ancestor := CurAncestor;
  348. break;
  349. end;
  350. end;
  351. end;
  352. // Do we have to call the OnFindAncestor callback?
  353. if Assigned(FOnFindAncestor) and
  354. ((not Assigned(Ancestor)) or Ancestor.InheritsFrom(TComponent)) then
  355. begin
  356. AncestorComponent := TComponent(Ancestor);
  357. FOnFindAncestor(Self, Component, Component.Name,
  358. AncestorComponent, FRootAncestor);
  359. Ancestor := AncestorComponent;
  360. end;
  361. // Finally write the component state
  362. Component.WriteState(Self);
  363. // The writing has been finished now...
  364. Exclude(Component.FComponentState, csWriting);
  365. finally
  366. Ancestor := SavedAncestor;
  367. FRootAncestor := SavedRootAncestor;
  368. end;
  369. end;
  370. procedure TWriter.WriteComponentData(Instance: TComponent);
  371. var
  372. SavedAncestorList: TList;
  373. SavedRoot, SavedRootAncestor: TComponent;
  374. SavedAncestorPos, SavedChildPos: Integer;
  375. Flags: TFilerFlags;
  376. begin
  377. // Determine the filer flags to store
  378. if Assigned(Ancestor) and ((not (csInline in Instance.ComponentState)) or
  379. ((csAncestor in Instance.ComponentState) and Assigned(FAncestorList))) then
  380. Flags := [ffInherited]
  381. else if csInline in Instance.ComponentState then
  382. Flags := [ffInline]
  383. else
  384. Flags := [];
  385. if Assigned(FAncestorList) and (FAncestorPos < FAncestorList.Count) and
  386. ((not Assigned(Ancestor)) or
  387. (TPersistent(FAncestorList[FAncestorPos]) <> Ancestor)) then
  388. Include(Flags, ffChildPos);
  389. Driver.BeginComponent(Instance, Flags, FChildPos);
  390. if Assigned(FAncestorList) and (FAncestorPos < FAncestorList.Count) then
  391. begin
  392. if Assigned(Ancestor) then
  393. Inc(FAncestorPos);
  394. Inc(FChildPos);
  395. end;
  396. // Write property list
  397. WriteProperties(Instance);
  398. WriteListEnd;
  399. // Write children list
  400. SavedAncestorList := FAncestorList;
  401. SavedAncestorPos := FAncestorPos;
  402. SavedChildPos := FChildPos;
  403. SavedRoot := FRoot;
  404. SavedRootAncestor := FRootAncestor;
  405. try
  406. FAncestorList := nil;
  407. FAncestorPos := 0;
  408. FChildPos := 0;
  409. if not IgnoreChildren then
  410. try
  411. // Set up the ancestor list if we have an ancestor
  412. if FAncestor is TComponent then
  413. begin
  414. if csInline in TComponent(FAncestor).ComponentState then
  415. FRootAncestor := TComponent(FAncestor);
  416. FAncestorList := TList.Create;
  417. TComponent(FAncestor).GetChildren(@AddToAncestorList, FRootAncestor);
  418. end;
  419. if csInline in Instance.ComponentState then
  420. FRoot := Instance;
  421. Instance.GetChildren(@WriteComponent, FRoot);
  422. finally
  423. FAncestorList.Free;
  424. end;
  425. finally
  426. FAncestorList := SavedAncestorList;
  427. FAncestorPos := SavedAncestorPos;
  428. FChildPos := SavedChildPos;
  429. FRoot := SavedRoot;
  430. FRootAncestor := SavedRootAncestor;
  431. end;
  432. WriteListEnd;
  433. end;
  434. procedure TWriter.WriteDescendent(ARoot: TComponent; AAncestor: TComponent);
  435. begin
  436. FRoot := ARoot;
  437. FAncestor := AAncestor;
  438. FRootAncestor := AAncestor;
  439. FLookupRoot := ARoot;
  440. WriteComponent(ARoot);
  441. end;
  442. procedure TWriter.WriteFloat(const Value: Extended);
  443. begin
  444. Driver.WriteFloat(Value);
  445. end;
  446. procedure TWriter.WriteSingle(const Value: Single);
  447. begin
  448. Driver.WriteSingle(Value);
  449. end;
  450. {!!!: procedure TWriter.WriteCurrency(const Value: Currency);
  451. begin
  452. Driver.WriteCurrency(Value);
  453. end;}
  454. procedure TWriter.WriteDate(const Value: TDateTime);
  455. begin
  456. Driver.WriteDate(Value);
  457. end;
  458. procedure TWriter.WriteIdent(const Ident: string);
  459. begin
  460. Driver.WriteIdent(Ident);
  461. end;
  462. procedure TWriter.WriteInteger(Value: LongInt);
  463. begin
  464. Driver.WriteInteger(Value);
  465. end;
  466. procedure TWriter.WriteInteger(Value: Int64);
  467. begin
  468. Driver.WriteInteger(Value);
  469. end;
  470. procedure TWriter.WriteListBegin;
  471. begin
  472. Driver.BeginList;
  473. end;
  474. procedure TWriter.WriteListEnd;
  475. begin
  476. Driver.EndList;
  477. end;
  478. procedure TWriter.WriteProperties(Instance: TPersistent);
  479. var
  480. i, PropCount: Integer;
  481. PropInfo: PPropInfo;
  482. PropList: PPropList;
  483. begin
  484. { First step: Write the properties given by the RTTI for Instance }
  485. PropCount := GetTypeData(Instance.ClassInfo)^.PropCount;
  486. if PropCount > 0 then
  487. begin
  488. GetMem(PropList, PropCount * SizeOf(PPropInfo));
  489. try
  490. GetPropInfos(Instance.ClassInfo, PropList);
  491. for i := 0 to PropCount - 1 do
  492. begin
  493. PropInfo := PropList^[i];
  494. if IsStoredProp(Instance, PropInfo) then
  495. WriteProperty(Instance, PropInfo);
  496. end;
  497. finally
  498. FreeMem(PropList);
  499. end;
  500. end;
  501. { Second step: Give Instance the chance to write its own private data }
  502. Instance.DefineProperties(Self);
  503. end;
  504. procedure TWriter.WriteProperty(Instance: TPersistent; PropInfo: Pointer);
  505. var
  506. HasAncestor: Boolean;
  507. PropType: PTypeInfo;
  508. Value, DefValue: LongInt;
  509. Ident: String;
  510. IntToIdentFn: TIntToIdent;
  511. FloatValue, DefFloatValue: Extended;
  512. MethodValue: TMethod;
  513. DefMethodCodeValue: Pointer;
  514. StrValue, DefStrValue: String;
  515. AncestorObj: TObject;
  516. Component: TComponent;
  517. ObjValue: TObject;
  518. SavedAncestor: TPersistent;
  519. SavedPropPath, Name: String;
  520. Int64Value, DefInt64Value: Int64;
  521. BoolValue, DefBoolValue: boolean;
  522. Handled: Boolean;
  523. begin
  524. if (not Assigned(PPropInfo(PropInfo)^.SetProc)) or
  525. (not Assigned(PPropInfo(PropInfo)^.GetProc)) then
  526. exit;
  527. { Check if the ancestor can be used }
  528. HasAncestor := Assigned(Ancestor) and ((Instance = Root) or
  529. (Instance.ClassType = Ancestor.ClassType));
  530. PropType := PPropInfo(PropInfo)^.PropType;
  531. case PropType^.Kind of
  532. tkInteger, tkChar, tkEnumeration, tkSet:
  533. begin
  534. Value := GetOrdProp(Instance, PropInfo);
  535. if HasAncestor then
  536. DefValue := GetOrdProp(Ancestor, PropInfo)
  537. else
  538. DefValue := PPropInfo(PropInfo)^.Default;
  539. if Value <> DefValue then
  540. begin
  541. Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
  542. case PropType^.Kind of
  543. tkInteger:
  544. begin
  545. // Check if this integer has a string identifier
  546. IntToIdentFn := FindIntToIdent(PPropInfo(PropInfo)^.PropType);
  547. if Assigned(IntToIdentFn) and IntToIdentFn(Value, Ident) then
  548. // Integer can be written a human-readable identifier
  549. WriteIdent(Ident)
  550. else
  551. // Integer has to be written just as number
  552. WriteInteger(Value);
  553. end;
  554. tkChar:
  555. WriteChar(Chr(Value));
  556. tkSet:
  557. Driver.WriteSet(Value, GetTypeData(PropType)^.CompType);
  558. tkEnumeration:
  559. WriteIdent(GetEnumName(PropType, Value));
  560. end;
  561. Driver.EndProperty;
  562. end;
  563. end;
  564. tkFloat:
  565. begin
  566. FloatValue := GetFloatProp(Instance, PropInfo);
  567. if HasAncestor then
  568. DefFloatValue := GetFloatProp(Ancestor, PropInfo)
  569. else
  570. DefFloatValue := 0;
  571. if FloatValue <> DefFloatValue then
  572. begin
  573. Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
  574. WriteFloat(FloatValue);
  575. Driver.EndProperty;
  576. end;
  577. end;
  578. tkMethod:
  579. begin
  580. MethodValue := GetMethodProp(Instance, PropInfo);
  581. if HasAncestor then
  582. DefMethodCodeValue := GetMethodProp(Ancestor, PropInfo).Code
  583. else
  584. DefMethodCodeValue := nil;
  585. Handled:=false;
  586. if Assigned(OnWriteMethodProperty) then
  587. OnWriteMethodProperty(Self,Instance,PPropInfo(PropInfo),MethodValue,
  588. DefMethodCodeValue,Handled);
  589. if (not Handled) and
  590. (MethodValue.Code <> DefMethodCodeValue) and
  591. ((not Assigned(MethodValue.Code)) or
  592. ((Length(FLookupRoot.MethodName(MethodValue.Code)) >= 0))) then
  593. begin
  594. Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
  595. if Assigned(MethodValue.Code) then
  596. Driver.WriteMethodName(FLookupRoot.MethodName(MethodValue.Code))
  597. else
  598. Driver.WriteMethodName('');
  599. Driver.EndProperty;
  600. end;
  601. end;
  602. tkSString, tkLString, tkAString, tkWString:
  603. // !!!: Can we really handle WideStrings here?
  604. begin
  605. StrValue := GetStrProp(Instance, PropInfo);
  606. if HasAncestor then
  607. DefStrValue := GetStrProp(Ancestor, PropInfo)
  608. else
  609. SetLength(DefStrValue, 0);
  610. if StrValue <> DefStrValue then
  611. begin
  612. Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
  613. WriteString(StrValue);
  614. Driver.EndProperty;
  615. end;
  616. end;
  617. {!!!: tkVariant:}
  618. tkClass:
  619. begin
  620. ObjValue := TObject(GetOrdProp(Instance, PropInfo));
  621. if HasAncestor then
  622. begin
  623. AncestorObj := TObject(GetOrdProp(Ancestor, PropInfo));
  624. if Assigned(AncestorObj) then
  625. if Assigned(ObjValue) and
  626. (TComponent(AncestorObj).Owner = FRootAncestor) and
  627. (TComponent(ObjValue).Owner = Root) and
  628. (UpperCase(TComponent(AncestorObj).Name) = UpperCase(TComponent(ObjValue).Name)) then
  629. AncestorObj := ObjValue
  630. else
  631. AncestorObj := nil;
  632. end else
  633. AncestorObj := nil;
  634. if not Assigned(ObjValue) then
  635. begin
  636. if ObjValue <> AncestorObj then
  637. begin
  638. Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
  639. Driver.WriteIdent('NIL');
  640. Driver.EndProperty;
  641. end
  642. end else if ObjValue.InheritsFrom(TPersistent) then
  643. if ObjValue.InheritsFrom(TComponent) then
  644. begin
  645. Component := TComponent(ObjValue);
  646. if ObjValue <> AncestorObj then
  647. begin
  648. { Determine the correct name of the component this property contains }
  649. if Component.Owner = LookupRoot then
  650. Name := Component.Name
  651. else if Component = LookupRoot then
  652. Name := 'Owner'
  653. else if Assigned(Component.Owner) and (Length(Component.Owner.Name) > 0)
  654. and (Length(Component.Name) > 0) then
  655. Name := Component.Owner.Name + '.' + Component.Name
  656. else if Length(Component.Name) > 0 then
  657. Name := Component.Name + '.Owner'
  658. else
  659. SetLength(Name, 0);
  660. if Length(Name) > 0 then
  661. begin
  662. Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
  663. WriteIdent(Name);
  664. Driver.EndProperty;
  665. end;
  666. end;
  667. end else if ObjValue.InheritsFrom(TCollection) then
  668. begin
  669. if (not HasAncestor) or (not CollectionsEqual(TCollection(ObjValue),
  670. TCollection(GetOrdProp(Ancestor, PropInfo)))) then
  671. begin
  672. Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
  673. SavedPropPath := FPropPath;
  674. try
  675. SetLength(FPropPath, 0);
  676. WriteCollection(TCollection(ObjValue));
  677. finally
  678. FPropPath := SavedPropPath;
  679. Driver.EndProperty;
  680. end;
  681. end;
  682. end else
  683. begin
  684. SavedAncestor := Ancestor;
  685. SavedPropPath := FPropPath;
  686. try
  687. FPropPath := FPropPath + PPropInfo(PropInfo)^.Name + '.';
  688. if HasAncestor then
  689. Ancestor := TPersistent(GetOrdProp(Ancestor, PropInfo));
  690. WriteProperties(TPersistent(ObjValue));
  691. finally
  692. Ancestor := SavedAncestor;
  693. FPropPath := SavedPropPath;
  694. end;
  695. end;
  696. end;
  697. tkInt64:
  698. begin
  699. Int64Value := GetInt64Prop(Instance, PropInfo);
  700. if HasAncestor then
  701. DefInt64Value := GetInt64Prop(Ancestor, PropInfo)
  702. else
  703. DefInt64Value := 0;
  704. if Int64Value <> DefInt64Value then
  705. begin
  706. Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
  707. WriteInteger(Int64Value);
  708. Driver.EndProperty;
  709. end;
  710. end;
  711. tkBool:
  712. begin
  713. BoolValue := GetOrdProp(Instance, PropInfo)<>0;
  714. if HasAncestor then
  715. DefBoolValue := GetOrdProp(Ancestor, PropInfo)<>0
  716. else
  717. DefBoolValue := PPropInfo(PropInfo)^.Default<>0;
  718. if BoolValue <> DefBoolValue then
  719. begin
  720. Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
  721. WriteBoolean(BoolValue);
  722. Driver.EndProperty;
  723. end;
  724. end;
  725. end;
  726. end;
  727. procedure TWriter.WriteRootComponent(ARoot: TComponent);
  728. begin
  729. WriteDescendent(ARoot, nil);
  730. end;
  731. procedure TWriter.WriteString(const Value: String);
  732. begin
  733. Driver.WriteString(Value);
  734. end;
  735. {!!!: procedure TWriter.WriteWideString(const Value: WideString);
  736. begin
  737. Driver.WriteWideString(Value);
  738. end;}
  739. {
  740. $Log$
  741. Revision 1.1 2003-10-06 20:33:58 peter
  742. * classes moved to rtl for 1.1
  743. * classes .inc and classes.pp files moved to fcl/classes for
  744. backwards 1.0.x compatiblity to have it in the fcl
  745. Revision 1.8 2003/08/16 15:50:47 michael
  746. + Fix from Mattias gaertner for IDE support
  747. Revision 1.7 2002/09/20 09:28:11 michael
  748. Fix from mattias gaertner
  749. Revision 1.6 2002/09/07 15:15:26 peter
  750. * old logs removed and tabs fixed
  751. Revision 1.5 2002/09/04 13:33:58 michael
  752. Fix from Mattias Gaertner, boolean streaming now respects default
  753. Revision 1.4 2002/09/03 06:02:57 michael
  754. + Applied patch from Matthias Gaertner to stream booleans
  755. }