<html><head></head><body><div class="ydp40678cc8yahoo-style-wrap" style="font-family: times new roman, new york, times, serif; font-size: 13px;"><div></div>
<div><span><div>Hi Guys</div><div><br></div><div>I have updated the demo of XComponents and XIDE in my dropbox</div><div><br></div><div>https://www.dropbox.com/sh/401ua59t0qmossd/AACVS4j2NJoLnPivKhfL7S3fa?dl=0</div><div><br></div><div>What is new?…….</div><div><br></div><div>1) New HTML files to show the new "Deploy" option in XIDE which can automatically create a web page for deployment of the IDE and/or project developed using it without needing any installation other than loading the HTML page into your browser.<br></div><div><br></div><div>2) Files providing XIDE run time modules for Windows and Android (in addition to those for the Browser platform already circulated).</div><div>This shows how XIDE and a demo project developed using it can behave in the same way in the Mobile, Desktop and Browser.</div><div><br></div><div>3)<span><span style="color: rgb(0, 0, 0); font-family: times new roman, new york, times, serif;"> A ReadMe that describes the project, its objectives, features, current status etc. </span></span></div><div><span><span style="color: rgb(0, 0, 0); font-family: times new roman, new york, times, serif;"><br></span></span></div><div>As usual all comments and suggestions welcome.</div><div><br></div><div>Steve</div><div><br></div></span><br></div><div><br></div>
</div><div id="ydp23a21a91yahoo_quoted_4269831987" class="ydp23a21a91yahoo_quoted">
<div style="font-family:'Helvetica Neue', Helvetica, Arial, sans-serif;font-size:13px;color:#26282a;">
<div>
On Friday, 30 November 2018, 17:16:32 GMT, <pas2js-request@lists.freepascal.org> wrote:
</div>
<div><br></div>
<div><br></div>
<div><div dir="ltr">Send Pas2js mailing list submissions to<br></div><div dir="ltr"> <a href="mailto:pas2js@lists.freepascal.org" rel="nofollow" target="_blank">pas2js@lists.freepascal.org</a><br></div><div dir="ltr"><br></div><div dir="ltr">To subscribe or unsubscribe via the World Wide Web, visit<br></div><div dir="ltr"> <a href="http://lists.freepascal.org/cgi-bin/mailman/listinfo/pas2js" rel="nofollow" target="_blank">http://lists.freepascal.org/cgi-bin/mailman/listinfo/pas2js</a><br></div><div dir="ltr">or, via email, send a message with subject or body 'help' to<br></div><div dir="ltr"> <a href="mailto:pas2js-request@lists.freepascal.org" rel="nofollow" target="_blank">pas2js-request@lists.freepascal.org</a><br></div><div dir="ltr"><br></div><div dir="ltr">You can reach the person managing the list at<br></div><div dir="ltr"> <a href="mailto:pas2js-owner@lists.freepascal.org" rel="nofollow" target="_blank">pas2js-owner@lists.freepascal.org</a><br></div><div dir="ltr"><br></div><div dir="ltr">When replying, please edit your Subject line so it is more specific<br></div><div dir="ltr">than "Re: Contents of Pas2js digest..."<br></div><div dir="ltr"><br></div><div dir="ltr"><br></div><div dir="ltr">Today's Topics:<br></div><div dir="ltr"><br></div><div dir="ltr"> 1. Re: Pas2JS Widget (Ulrich, Christian)<br></div><div dir="ltr"> 2. Re: Pas2JS Widget (warleyalex)<br></div><div dir="ltr"><br></div><div dir="ltr"><br></div><div dir="ltr">----------------------------------------------------------------------<br></div><div dir="ltr"><br></div><div dir="ltr">Message: 1<br></div><div dir="ltr">Date: Fri, 30 Nov 2018 12:17:27 +0000<br></div><div dir="ltr">From: "Ulrich, Christian" <<a href="mailto:christian.ulrich@tcsag.de" rel="nofollow" target="_blank">christian.ulrich@tcsag.de</a>><br></div><div dir="ltr">To: pas2js discussions <<a href="mailto:pas2js@lists.freepascal.org" rel="nofollow" target="_blank">pas2js@lists.freepascal.org</a>><br></div><div dir="ltr">Subject: Re: [Pas2js] Pas2JS Widget<br></div><div dir="ltr">Message-ID:<br></div><div dir="ltr"> <<a href="mailto:20072D672807864B91DBC370126A25E4224FC6FF@Server22.tcs.biz" rel="nofollow" target="_blank">20072D672807864B91DBC370126A25E4224FC6FF@Server22.tcs.biz</a>><br></div><div dir="ltr">Content-Type: text/plain; charset="utf-8"<br></div><div dir="ltr"><br></div><div dir="ltr">Hi,<br></div><div dir="ltr"><br></div><div dir="ltr">I have taken an deeper look.<br></div><div dir="ltr">I would suggest that only one package for the widgets exists, the controls for ide and real widgets could be separated by include files ($I) and ifdefs per plattform.<br></div><div dir="ltr">So the ide would not try to add the Fake package every time.<br></div><div dir="ltr"><br></div><div dir="ltr">I would also like to ask (like warleyalex) if you could add the source for the build tool.<br></div><div dir="ltr">I think that would be the point where I would fork the repo and start to make pull requests.<br></div><div dir="ltr"><br></div><div dir="ltr">The general way seems to be nice for an widgetset. I will make an extra package with an Navigation bar.<br></div><div dir="ltr"><br></div><div dir="ltr"><br></div><div dir="ltr"><br></div><div dir="ltr"><br></div><div dir="ltr">Christian Ulrich<br></div><div dir="ltr">Teamleiter Prüfmittelbau<br></div><div dir="ltr"><br></div><div dir="ltr">______________________________________________________________________<br></div><div dir="ltr"><br></div><div dir="ltr"><br></div><div dir="ltr">TCS TürControlSysteme AG Geschwister-Scholl-Str. 7 | D-39307 Genthin<br></div><div dir="ltr">Telefon +49 3933 8799-433 | Fax +49 3933 8799-84 | Mail <a href="mailto:christian.ulrich@tcsag.de" rel="nofollow" target="_blank">christian.ulrich@tcsag.de</a> | www.tcsag.de<br></div><div dir="ltr"><br></div><div dir="ltr">Vorstand: Dipl.-Ing. (FH) Otto Duffner (Vorsitzender), Florian Herth<br></div><div dir="ltr">Aufsichtsrat: Dipl. El. Ing FH/ EMBA Jörg Stocker<br></div><div dir="ltr">Sitz der Gesellschaft: Genthin | HRB 3909 AG Stendal<br></div><div dir="ltr">-----Ursprüngliche Nachricht-----<br></div><div dir="ltr">Von: Pas2js [mailto:<a href="mailto:pas2js-bounces@lists.freepascal.org" rel="nofollow" target="_blank">pas2js-bounces@lists.freepascal.org</a>] Im Auftrag von heliosroots<br></div><div dir="ltr">Gesendet: Mittwoch, 14. November 2018 10:47<br></div><div dir="ltr">An: <a href="mailto:pas2js@lists.freepascal.org" rel="nofollow" target="_blank">pas2js@lists.freepascal.org</a><br></div><div dir="ltr">Betreff: [Pas2js] Pas2JS Widget<br></div><div dir="ltr"><br></div><div dir="ltr"><a href="https://github.com/heliosroots/Pas2JS " rel="nofollow" target="_blank">https://github.com/heliosroots/Pas2JS </a><<a href="https://github.com/heliosroots/Pas2JS" rel="nofollow" target="_blank">https://github.com/heliosroots/Pas2JS</a>><br></div><div dir="ltr"><br></div><div dir="ltr"><br></div><div dir="ltr"><br></div><div dir="ltr">--<br></div><div dir="ltr">Sent from: <a href="http://pas2js.38893.n8.nabble.com/" rel="nofollow" target="_blank">http://pas2js.38893.n8.nabble.com/</a><br></div><div dir="ltr">_______________________________________________<br></div><div dir="ltr">Pas2js maillist - <a href="mailto:Pas2js@lists.freepascal.org" rel="nofollow" target="_blank">Pas2js@lists.freepascal.org</a><br></div><div dir="ltr"><a href="http://lists.freepascal.org/cgi-bin/mailman/listinfo/pas2js" rel="nofollow" target="_blank">http://lists.freepascal.org/cgi-bin/mailman/listinfo/pas2js</a><br></div><div dir="ltr"><br></div><div dir="ltr">------------------------------<br></div><div dir="ltr"><br></div><div dir="ltr">Message: 2<br></div><div dir="ltr">Date: Fri, 30 Nov 2018 11:16:19 -0600 (CST)<br></div><div dir="ltr">From: warleyalex <<a href="mailto:warleyalex@yahoo.com.br" rel="nofollow" target="_blank">warleyalex@yahoo.com.br</a>><br></div><div dir="ltr">To: <a href="mailto:pas2js@lists.freepascal.org" rel="nofollow" target="_blank">pas2js@lists.freepascal.org</a><br></div><div dir="ltr">Subject: Re: [Pas2js] Pas2JS Widget<br></div><div dir="ltr">Message-ID: <<a href="mailto:1543598179830-0.post@n8.nabble.com" rel="nofollow" target="_blank">1543598179830-0.post@n8.nabble.com</a>><br></div><div dir="ltr">Content-Type: text/plain; charset=us-ascii<br></div><div dir="ltr"><br></div><div dir="ltr">Ulrich, Christian wrote<br></div><div dir="ltr">> I have taken an deeper look.<br></div><div dir="ltr"><br></div><div dir="ltr">The Helios's widgets are dependent of the the closed source executable<br></div><div dir="ltr">"pas2js_build.exe" :(<br></div><div dir="ltr">...the good news is you can compile the same widgets without this tool :)<br></div><div dir="ltr"><br></div><div dir="ltr">The Helios's tool uses a precompiler that converts native widget to web<br></div><div dir="ltr">widget with structure similar to LCL and injects into loader session, he<br></div><div dir="ltr">performs the form serialization using this closed tool "pas2js_build.exe".<br></div><div dir="ltr">but it seems this tool is using CompWriterPas to perform the serialization<br></div><div dir="ltr">straightforward on before save the the project serialize the forms on the<br></div><div dir="ltr">fly.<br></div><div dir="ltr">for instance, the "unit1.lfm" becomes "unit1.wfm"<br></div><div dir="ltr"><br></div><div dir="ltr">If you can modify the plugins/project:<br></div><div dir="ltr"> <br></div><div dir="ltr"><a href="https://github.com/pas2js/master/blob/master/pas2jsdsgn_plus.rar" rel="nofollow" target="_blank">https://github.com/pas2js/master/blob/master/pas2jsdsgn_plus.rar</a><br></div><div dir="ltr"><br></div><div dir="ltr">This is a modified pas2jsdsgn package. You can merge with Helios's<br></div><div dir="ltr">implementations, and create a simple package without pas2js_build<br></div><div dir="ltr">dependency.<br></div><div dir="ltr"><br></div><div dir="ltr">I sincerely don't have enough time to sit down and finish the CompWriterPas<br></div><div dir="ltr">unit.<br></div><div dir="ltr"><br></div><div dir="ltr">for instance below, the unit1.lfm become Form1.lfm.inc. <br></div><div dir="ltr"><br></div><div dir="ltr">Note that a CompWriterPas modification is required.<br></div><div dir="ltr">Look the block try..finally used in the serialization.<br></div><div dir="ltr">Some non visual components like "TClientDataSet" which base class is<br></div><div dir="ltr">TComponent, shouldn't be envolved with try..finally block.<br></div><div dir="ltr"><br></div><div dir="ltr">Another thing, I believe the property "Parent" should comes first, like<br></div><div dir="ltr">WebDBLabel1.Parent := Self;<br></div><div dir="ltr"><br></div><div dir="ltr"><br></div><div dir="ltr">//--The Form1.lfm.inc ---------------------------<br></div><div dir="ltr"> WebDBLabel1:= TDBLabel.Create(Self);<br></div><div dir="ltr"> WebLabel1:= TLabel.Create(Self);<br></div><div dir="ltr"> WebLabel2:= TLabel.Create(Self);<br></div><div dir="ltr"> WebLabel3:= TLabel.Create(Self);<br></div><div dir="ltr"> WebLabel4:= TLabel.Create(Self);<br></div><div dir="ltr"> WebLabel6:= TLabel.Create(Self);<br></div><div dir="ltr"> WebLabel7:= TLabel.Create(Self);<br></div><div dir="ltr"> WebLabel5:= TLabel.Create(Self);<br></div><div dir="ltr"> WebButton1:= TButton.Create(Self);<br></div><div dir="ltr"> WebDBNavigator1:= TDBNavigator.Create(Self);<br></div><div dir="ltr"> WebDBEdit1:= TDBEdit.Create(Self);<br></div><div dir="ltr"> WebDBEdit2:= TDBEdit.Create(Self);<br></div><div dir="ltr"> WebDBEdit3:= TDBEdit.Create(Self);<br></div><div dir="ltr"> WebDBEdit4:= TDBEdit.Create(Self);<br></div><div dir="ltr"> WebPanel1:= TPanel.Create(Self);<br></div><div dir="ltr"> WebLabel9:= TLabel.Create(WebPanel1);<br></div><div dir="ltr"> WebImageControl1:= TImageControl.Create(WebPanel1);<br></div><div dir="ltr"> WebDBMemo1:= TDBMemo.Create(Self);<br></div><div dir="ltr"> WebDBSpinEdit1:= TDBSpinEdit.Create(Self);<br></div><div dir="ltr"><br></div><div dir="ltr"> WebClientConnection1:= TClientConnection.Create(Self);<br></div><div dir="ltr"> WebClientDataSet1:= TClientDataSet.Create(Self);<br></div><div dir="ltr"> WebClientDataSource1:= TClientDataSource.Create(Self);<br></div><div dir="ltr"><br></div><div dir="ltr"> WebDBLabel1.BeginUpdate;<br></div><div dir="ltr"> WebLabel1.BeginUpdate;<br></div><div dir="ltr"> WebLabel2.BeginUpdate;<br></div><div dir="ltr"> WebLabel3.BeginUpdate;<br></div><div dir="ltr"> WebLabel4.BeginUpdate;<br></div><div dir="ltr"> WebLabel6.BeginUpdate;<br></div><div dir="ltr"> WebLabel7.BeginUpdate;<br></div><div dir="ltr"> WebLabel5.BeginUpdate;<br></div><div dir="ltr"> WebButton1.BeginUpdate;<br></div><div dir="ltr"> WebDBNavigator1.BeginUpdate;<br></div><div dir="ltr"> WebDBEdit1.BeginUpdate;<br></div><div dir="ltr"> WebDBEdit2.BeginUpdate;<br></div><div dir="ltr"> WebDBEdit3.BeginUpdate;<br></div><div dir="ltr"> WebDBEdit4.BeginUpdate;<br></div><div dir="ltr"> WebPanel1.BeginUpdate;<br></div><div dir="ltr"> WebLabel9.BeginUpdate;<br></div><div dir="ltr"> WebImageControl1.BeginUpdate;<br></div><div dir="ltr"> WebDBMemo1.BeginUpdate;<br></div><div dir="ltr"> WebDBSpinEdit1.BeginUpdate;<br></div><div dir="ltr"><br></div><div dir="ltr"> try<br></div><div dir="ltr"> Self.Name := 'Form1';<br></div><div dir="ltr"> Self.Left := 0;<br></div><div dir="ltr"> Self.Top := 0;<br></div><div dir="ltr"> Self.Width := 775;<br></div><div dir="ltr"> Self.Height := 575;<br></div><div dir="ltr"> Self.Font.Charset := 1;<br></div><div dir="ltr"> Self.Font.Color := 0;<br></div><div dir="ltr"> Self.Font.Height := -13;<br></div><div dir="ltr"> Self.Font.Name := 'Tahoma';<br></div><div dir="ltr"> Self.Font.Style := [];<br></div><div dir="ltr"> Self.FFormContainer := 'appcontent';<br></div><div dir="ltr"> Self.TabOrder := 1;<br></div><div dir="ltr"><br></div><div dir="ltr"> WebDBLabel1.Parent := Self;<br></div><div dir="ltr"> WebDBLabel1.Name := 'WebDBLabel1';<br></div><div dir="ltr"> WebDBLabel1.Left := 132;<br></div><div dir="ltr"> WebDBLabel1.Top := 257;<br></div><div dir="ltr"> WebDBLabel1.Width := 457;<br></div><div dir="ltr"> WebDBLabel1.Height := 22;<br></div><div dir="ltr"> WebDBLabel1.AutoSize := false;<br></div><div dir="ltr"> WebDBLabel1.Caption := 'WebDBLabel1';<br></div><div dir="ltr"> WebDBLabel1.EllipsisPosition := epEndEllipsis;<br></div><div dir="ltr"> WebDBLabel1.DataField := '_Length_In';<br></div><div dir="ltr"> WebDBLabel1.DataSource := WebClientDataSource1;<br></div><div dir="ltr"><br></div><div dir="ltr"> WebLabel1.Parent := Self;<br></div><div dir="ltr"> WebLabel1.Name := 'WebLabel1';<br></div><div dir="ltr"> WebLabel1.Left := 16;<br></div><div dir="ltr"> WebLabel1.Top := 98;<br></div><div dir="ltr"> WebLabel1.Width := 68;<br></div><div dir="ltr"> WebLabel1.Height := 16;<br></div><div dir="ltr"> WebLabel1.Caption := 'Species No:';<br></div><div dir="ltr"><br></div><div dir="ltr"> WebLabel2.Parent := Self;<br></div><div dir="ltr"> WebLabel2.Name := 'WebLabel2';<br></div><div dir="ltr"> WebLabel2.Left := 16;<br></div><div dir="ltr"> WebLabel2.Top := 130;<br></div><div dir="ltr"> WebLabel2.Width := 56;<br></div><div dir="ltr"> WebLabel2.Height := 16;<br></div><div dir="ltr"> WebLabel2.Caption := 'Category:';<br></div><div dir="ltr"><br></div><div dir="ltr"> WebLabel3.Parent := Self;<br></div><div dir="ltr"> WebLabel3.Name := 'WebLabel3';<br></div><div dir="ltr"> WebLabel3.Left := 16;<br></div><div dir="ltr"> WebLabel3.Top := 162;<br></div><div dir="ltr"> WebLabel3.Width := 93;<br></div><div dir="ltr"> WebLabel3.Height := 16;<br></div><div dir="ltr"> WebLabel3.Caption := 'Common Name:';<br></div><div dir="ltr"><br></div><div dir="ltr"> WebLabel4.Parent := Self;<br></div><div dir="ltr"> WebLabel4.Name := 'WebLabel4';<br></div><div dir="ltr"> WebLabel4.Left := 16;<br></div><div dir="ltr"> WebLabel4.Top := 195;<br></div><div dir="ltr"> WebLabel4.Width := 86;<br></div><div dir="ltr"> WebLabel4.Height := 16;<br></div><div dir="ltr"> WebLabel4.Caption := 'Species Name:';<br></div><div dir="ltr"><br></div><div dir="ltr"> WebLabel6.Parent := Self;<br></div><div dir="ltr"> WebLabel6.Name := 'WebLabel6';<br></div><div dir="ltr"> WebLabel6.Left := 16;<br></div><div dir="ltr"> WebLabel6.Top := 226;<br></div><div dir="ltr"> WebLabel6.Width := 64;<br></div><div dir="ltr"> WebLabel6.Height := 16;<br></div><div dir="ltr"> WebLabel6.Caption := 'Length cm:';<br></div><div dir="ltr"><br></div><div dir="ltr"> WebLabel7.Parent := Self;<br></div><div dir="ltr"> WebLabel7.Name := 'WebLabel7';<br></div><div dir="ltr"> WebLabel7.Left := 16;<br></div><div dir="ltr"> WebLabel7.Top := 257;<br></div><div dir="ltr"> WebLabel7.Width := 58;<br></div><div dir="ltr"> WebLabel7.Height := 16;<br></div><div dir="ltr"> WebLabel7.Caption := 'Length In:';<br></div><div dir="ltr"><br></div><div dir="ltr"> WebLabel5.Parent := Self;<br></div><div dir="ltr"> WebLabel5.Name := 'WebLabel5';<br></div><div dir="ltr"> WebLabel5.Left := 16;<br></div><div dir="ltr"> WebLabel5.Top := 288;<br></div><div dir="ltr"> WebLabel5.Width := 37;<br></div><div dir="ltr"> WebLabel5.Height := 16;<br></div><div dir="ltr"> WebLabel5.Caption := 'Notes:';<br></div><div dir="ltr"><br></div><div dir="ltr"> WebButton1.Parent := Self;<br></div><div dir="ltr"> WebButton1.Name := 'WebButton1';<br></div><div dir="ltr"> WebButton1.Left := 16;<br></div><div dir="ltr"> WebButton1.Top := 16;<br></div><div dir="ltr"> WebButton1.Width := 153;<br></div><div dir="ltr"> WebButton1.Height := 25;<br></div><div dir="ltr"> WebButton1.Caption := 'Connect to DB';<br></div><div dir="ltr"> WebButton1.OnClick := @WebButton1Click;<br></div><div dir="ltr"> WebButton1.TabOrder := 0;<br></div><div dir="ltr"><br></div><div dir="ltr"> WebDBNavigator1.Parent := Self;<br></div><div dir="ltr"> WebDBNavigator1.Name := 'WebDBNavigator1';<br></div><div dir="ltr"> WebDBNavigator1.Left := 132;<br></div><div dir="ltr"> WebDBNavigator1.Top := 60;<br></div><div dir="ltr"> WebDBNavigator1.Width := 288;<br></div><div dir="ltr"> WebDBNavigator1.Height := 25;<br></div><div dir="ltr"> WebDBNavigator1.DataSource := WebClientDataSource1;<br></div><div dir="ltr"><br></div><div dir="ltr"> WebDBEdit1.Parent := Self;<br></div><div dir="ltr"> WebDBEdit1.Name := 'WebDBEdit1';<br></div><div dir="ltr"> WebDBEdit1.Left := 132;<br></div><div dir="ltr"> WebDBEdit1.Top := 95;<br></div><div dir="ltr"> WebDBEdit1.Width := 457;<br></div><div dir="ltr"> WebDBEdit1.Height := 24;<br></div><div dir="ltr"> WebDBEdit1.AutoSelect := false;<br></div><div dir="ltr"> WebDBEdit1.Color := 16777215;<br></div><div dir="ltr"> WebDBEdit1.HideSelection := false;<br></div><div dir="ltr"> WebDBEdit1.TabOrder := 2;<br></div><div dir="ltr"> WebDBEdit1.Text := 'WebDBEdit1';<br></div><div dir="ltr"> WebDBEdit1.DataField := '_Species_No';<br></div><div dir="ltr"> WebDBEdit1.DataSource := WebClientDataSource1;<br></div><div dir="ltr"><br></div><div dir="ltr"> WebDBEdit2.Parent := Self;<br></div><div dir="ltr"> WebDBEdit2.Name := 'WebDBEdit2';<br></div><div dir="ltr"> WebDBEdit2.Left := 132;<br></div><div dir="ltr"> WebDBEdit2.Top := 127;<br></div><div dir="ltr"> WebDBEdit2.Width := 457;<br></div><div dir="ltr"> WebDBEdit2.Height := 24;<br></div><div dir="ltr"> WebDBEdit2.AutoSelect := false;<br></div><div dir="ltr"> WebDBEdit2.Color := 16777215;<br></div><div dir="ltr"> WebDBEdit2.HideSelection := false;<br></div><div dir="ltr"> WebDBEdit2.TabOrder := 3;<br></div><div dir="ltr"> WebDBEdit2.Text := 'WebDBEdit1';<br></div><div dir="ltr"> WebDBEdit2.DataField := '_Category';<br></div><div dir="ltr"> WebDBEdit2.DataSource := WebClientDataSource1;<br></div><div dir="ltr"><br></div><div dir="ltr"> WebDBEdit3.Parent := Self;<br></div><div dir="ltr"> WebDBEdit3.Name := 'WebDBEdit3';<br></div><div dir="ltr"> WebDBEdit3.Left := 132;<br></div><div dir="ltr"> WebDBEdit3.Top := 159;<br></div><div dir="ltr"> WebDBEdit3.Width := 457;<br></div><div dir="ltr"> WebDBEdit3.Height := 24;<br></div><div dir="ltr"> WebDBEdit3.AutoSelect := false;<br></div><div dir="ltr"> WebDBEdit3.Color := 16777215;<br></div><div dir="ltr"> WebDBEdit3.HideSelection := false;<br></div><div dir="ltr"> WebDBEdit3.TabOrder := 4;<br></div><div dir="ltr"> WebDBEdit3.Text := 'WebDBEdit1';<br></div><div dir="ltr"> WebDBEdit3.DataField := '_Common_Name';<br></div><div dir="ltr"> WebDBEdit3.DataSource := WebClientDataSource1;<br></div><div dir="ltr"><br></div><div dir="ltr"> WebDBEdit4.Parent := Self;<br></div><div dir="ltr"> WebDBEdit4.Name := 'WebDBEdit4';<br></div><div dir="ltr"> WebDBEdit4.Left := 132;<br></div><div dir="ltr"> WebDBEdit4.Top := 192;<br></div><div dir="ltr"> WebDBEdit4.Width := 457;<br></div><div dir="ltr"> WebDBEdit4.Height := 24;<br></div><div dir="ltr"> WebDBEdit4.AutoSelect := false;<br></div><div dir="ltr"> WebDBEdit4.Color := 16777215;<br></div><div dir="ltr"> WebDBEdit4.HideSelection := false;<br></div><div dir="ltr"> WebDBEdit4.TabOrder := 5;<br></div><div dir="ltr"> WebDBEdit4.Text := 'WebDBEdit1';<br></div><div dir="ltr"> WebDBEdit4.DataField := '_Species_Name';<br></div><div dir="ltr"> WebDBEdit4.DataSource := WebClientDataSource1;<br></div><div dir="ltr"><br></div><div dir="ltr"> WebPanel1.Parent := Self;<br></div><div dir="ltr"> WebPanel1.Name := 'WebPanel1';<br></div><div dir="ltr"> WebPanel1.Left := 16;<br></div><div dir="ltr"> WebPanel1.Top := 465;<br></div><div dir="ltr"> WebPanel1.Width := 541;<br></div><div dir="ltr"> WebPanel1.Height := 89;<br></div><div dir="ltr"> WebPanel1.WidthStyle := ssPercent;<br></div><div dir="ltr"> WebPanel1.WidthPercent := 80;<br></div><div dir="ltr"> WebPanel1.BorderStyle := bsSingle;<br></div><div dir="ltr"><br></div><div dir="ltr"> WebLabel9.Parent := WebPanel1;<br></div><div dir="ltr"> WebLabel9.Name := 'WebLabel9';<br></div><div dir="ltr"> WebLabel9.Left := 3;<br></div><div dir="ltr"> WebLabel9.Top := 29;<br></div><div dir="ltr"> WebLabel9.Width := 460;<br></div><div dir="ltr"> WebLabel9.Height := 48;<br></div><div dir="ltr"> WebLabel9.Caption :=<br></div><div dir="ltr"> 'Self demo shows a web client dataset connected to DB controls. The<br></div><div dir="ltr">web client dataset gets the information from an Client server but for demo<br></div><div dir="ltr">purposes all editing in the dataset is local in the web client only!';<br></div><div dir="ltr"> WebLabel9.WordWrap := true;<br></div><div dir="ltr"> WebLabel9.WidthStyle := ssPercent;<br></div><div dir="ltr"><br></div><div dir="ltr"> WebImageControl1.Parent := WebPanel1;<br></div><div dir="ltr"> WebImageControl1.Name := 'WebImageControl1';<br></div><div dir="ltr"> WebImageControl1.Left := 6;<br></div><div dir="ltr"> WebImageControl1.Top := 7;<br></div><div dir="ltr"> WebImageControl1.Width := 16;<br></div><div dir="ltr"> WebImageControl1.Height := 16;<br></div><div dir="ltr"> WebImageControl1.AutoSize := true;<br></div><div dir="ltr"> WebImageControl1.Picture.LoadFromFile('Picture.png');<br></div><div dir="ltr"><br></div><div dir="ltr"> WebDBMemo1.Parent := Self;<br></div><div dir="ltr"> WebDBMemo1.Name := 'WebDBMemo1';<br></div><div dir="ltr"> WebDBMemo1.Left := 132;<br></div><div dir="ltr"> WebDBMemo1.Top := 285;<br></div><div dir="ltr"> WebDBMemo1.Width := 457;<br></div><div dir="ltr"> WebDBMemo1.Height := 140;<br></div><div dir="ltr"> WebDBMemo1.AutoSize := false;<br></div><div dir="ltr"> WebDBMemo1.Lines.BeginUpdate;<br></div><div dir="ltr"> try<br></div><div dir="ltr"> WebDBMemo1.Lines.Clear;<br></div><div dir="ltr"> WebDBMemo1.Lines.Add('WebDBMemo1');<br></div><div dir="ltr"> finally<br></div><div dir="ltr"> WebDBMemo1.Lines.EndUpdate;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> WebDBMemo1.SelLength := 0;<br></div><div dir="ltr"> WebDBMemo1.SelStart := 0;<br></div><div dir="ltr"> WebDBMemo1.TabOrder := 7;<br></div><div dir="ltr"> WebDBMemo1.DataField := '_Notes';<br></div><div dir="ltr"> WebDBMemo1.DataSource := WebClientDataSource1;<br></div><div dir="ltr"><br></div><div dir="ltr"> WebDBSpinEdit1.Parent := Self;<br></div><div dir="ltr"> WebDBSpinEdit1.Name := 'WebDBSpinEdit1';<br></div><div dir="ltr"> WebDBSpinEdit1.Left := 132;<br></div><div dir="ltr"> WebDBSpinEdit1.Top := 223;<br></div><div dir="ltr"> WebDBSpinEdit1.Width := 150;<br></div><div dir="ltr"> WebDBSpinEdit1.Height := 22;<br></div><div dir="ltr"> WebDBSpinEdit1.AutoSize := false;<br></div><div dir="ltr"> WebDBSpinEdit1.BorderStyle := bsSingle;<br></div><div dir="ltr"> WebDBSpinEdit1.Color := 16777215;<br></div><div dir="ltr"> WebDBSpinEdit1.Increment := 1;<br></div><div dir="ltr"> WebDBSpinEdit1.MaxValue := 100;<br></div><div dir="ltr"> WebDBSpinEdit1.MinValue := 0;<br></div><div dir="ltr"> WebDBSpinEdit1.TabOrder := 8;<br></div><div dir="ltr"> WebDBSpinEdit1.Value := 0;<br></div><div dir="ltr"> WebDBSpinEdit1.DataField := '_Length__cm_';<br></div><div dir="ltr"> WebDBSpinEdit1.DataSource := WebClientDataSource1;<br></div><div dir="ltr"><br></div><div dir="ltr"> WebClientConnection1.Name := 'WebClientConnection1';<br></div><div dir="ltr"> WebClientConnection1.Active := false;<br></div><div dir="ltr"> WebClientDataSet1.Name := 'WebClientDataSet1';<br></div><div dir="ltr"> WebClientDataSet1.Connection := WebClientConnection1;<br></div><div dir="ltr"><br></div><div dir="ltr"> WebClientDataSource1.Name := 'WebClientDataSource1';<br></div><div dir="ltr"> WebClientDataSource1.DataSet := WebClientDataSet1;<br></div><div dir="ltr"> finally<br></div><div dir="ltr"> WebDBLabel1.EndUpdate;<br></div><div dir="ltr"> WebLabel1.EndUpdate;<br></div><div dir="ltr"> WebLabel2.EndUpdate;<br></div><div dir="ltr"> WebLabel3.EndUpdate;<br></div><div dir="ltr"> WebLabel4.EndUpdate;<br></div><div dir="ltr"> WebLabel6.EndUpdate;<br></div><div dir="ltr"> WebLabel7.EndUpdate;<br></div><div dir="ltr"> WebLabel5.EndUpdate;<br></div><div dir="ltr"> WebButton1.EndUpdate;<br></div><div dir="ltr"> WebDBNavigator1.EndUpdate;<br></div><div dir="ltr"> WebDBEdit1.EndUpdate;<br></div><div dir="ltr"> WebDBEdit2.EndUpdate;<br></div><div dir="ltr"> WebDBEdit3.EndUpdate;<br></div><div dir="ltr"> WebDBEdit4.EndUpdate;<br></div><div dir="ltr"> WebPanel1.EndUpdate;<br></div><div dir="ltr"> WebLabel9.EndUpdate;<br></div><div dir="ltr"> WebImageControl1.EndUpdate;<br></div><div dir="ltr"> WebDBMemo1.EndUpdate;<br></div><div dir="ltr"> WebDBSpinEdit1.EndUpdate;<br></div><div dir="ltr"> end;<br></div><div dir="ltr">//-----------------------------<br></div><div dir="ltr"><br></div><div dir="ltr">Here is the modified ComWriterPas unit. The feature "non visual components,<br></div><div dir="ltr">based on the base class TComponent, those components are not involved on the<br></div><div dir="ltr">try..finally block", this feature is not yet implemented at the unit.<br></div><div dir="ltr"><br></div><div dir="ltr">--// CompWriterPas unit -------------------<br></div><div dir="ltr">{<br></div><div dir="ltr"><br></div><div dir="ltr">*****************************************************************************<br></div><div dir="ltr"> This file is part of the Lazarus Component Library (LCL)<br></div><div dir="ltr"><br></div><div dir="ltr"> See the file COPYING.modifiedLGPL.txt, included in this distribution,<br></div><div dir="ltr"> for details about the license.<br></div><div dir="ltr"><br></div><div dir="ltr">*****************************************************************************<br></div><div dir="ltr"><br></div><div dir="ltr">Component serialisation into Pascal.<br></div><div dir="ltr"><br></div><div dir="ltr">Author: Mattias Gaertner<br></div><div dir="ltr"><br></div><div dir="ltr">Working:<br></div><div dir="ltr">- signature begin, end, version<br></div><div dir="ltr">- boolean, set of boolean<br></div><div dir="ltr">- char, widechar, custom char, set of custom char<br></div><div dir="ltr">- integers, custom int, set of custom int<br></div><div dir="ltr">- strings, codepage system and UTF8<br></div><div dir="ltr">- float, currency<br></div><div dir="ltr">- enum, custom enum range<br></div><div dir="ltr">- set of enum, set of custom enum range<br></div><div dir="ltr">- variant: integers, boolean, string, floats, currency<br></div><div dir="ltr">- method<br></div><div dir="ltr">- persistent<br></div><div dir="ltr">- component children, use SetParentComponent or optional Parent:=<br></div><div dir="ltr">- collection<br></div><div dir="ltr">- IInterfaceComponentReference<br></div><div dir="ltr">- with ancestor<br></div><div dir="ltr">- ancestor: change ComponentIndex -> call SetChildPos<br></div><div dir="ltr">- reference foreign root, reference foreign component<br></div><div dir="ltr">- create components before setting properties to avoid having to set<br></div><div dir="ltr">references<br></div><div dir="ltr"> later<br></div><div dir="ltr">- inline component, csInline, call SetInline, inherited inline, inline on<br></div><div dir="ltr">inherited<br></div><div dir="ltr">- TComponent.Left/Right via DesignInfo<br></div><div dir="ltr">- DefineProperties<br></div><div dir="ltr">- RegisterDefinePropertiesPas<br></div><div dir="ltr">}<br></div><div dir="ltr"><br></div><div dir="ltr">unit CompWriterPas;<br></div><div dir="ltr"><br></div><div dir="ltr">{$mode objfpc}{$H+}<br></div><div dir="ltr"><br></div><div dir="ltr">{off $DEFINE VerboseCompWriterPas}<br></div><div dir="ltr"><br></div><div dir="ltr">interface<br></div><div dir="ltr"><br></div><div dir="ltr">uses<br></div><div dir="ltr"> Classes, SysUtils, typinfo, RtlConsts, contnrs, LazLoggerBase, LazUTF8;<br></div><div dir="ltr"><br></div><div dir="ltr">const<br></div><div dir="ltr"> // Component serialized as Pascal<br></div><div dir="ltr"> CSPVersion = 1;<br></div><div dir="ltr"> CSPDefaultSignature = '// Component serialized as Pascal';<br></div><div dir="ltr"> CSPDefaultSignatureBegin = CSPDefaultSignature+' - Begin';<br></div><div dir="ltr"> CSPDefaultSignatureEnd = CSPDefaultSignature+' - End';<br></div><div dir="ltr"> CSPDefaultAccessClass = 'TPasStreamAccess';<br></div><div dir="ltr"> CSPDefaultExecCustomProc = 'ExecCustomCSP';<br></div><div dir="ltr"> CSPDefaultExecCustomProcUnit = 'LazPasReadUtil';<br></div><div dir="ltr"> CSPDefaultMaxColumn = 80;<br></div><div dir="ltr"> CSPDefaultAssignOp = ':=';<br></div><div dir="ltr"> CWPSkipParentName = '-';<br></div><div dir="ltr">type<br></div><div dir="ltr"> TCompWriterPas = class;<br></div><div dir="ltr"> TCWPFindAncestorEvent = procedure(Writer: TCompWriterPas; Component:<br></div><div dir="ltr">TComponent;<br></div><div dir="ltr"> const Name: string; var Ancestor, RootAncestor: TComponent) of object;<br></div><div dir="ltr"> TCWPGetMethodName = procedure(Writer: TCompWriterPas; Instance:<br></div><div dir="ltr">TPersistent;<br></div><div dir="ltr"> PropInfo: PPropInfo; out Name: String) of object;<br></div><div dir="ltr"> TCWPGetParentPropertyEvent = procedure(Writer: TCompWriterPas;<br></div><div dir="ltr"> Component: TComponent; var PropName: string) of object;<br></div><div dir="ltr"> TCWPDefinePropertiesEvent = procedure(Writer: TCompWriterPas;<br></div><div dir="ltr"> Instance: TPersistent; const Identifier: string; var Handled: boolean)<br></div><div dir="ltr">of object;<br></div><div dir="ltr"><br></div><div dir="ltr"> TCWPOption = (<br></div><div dir="ltr"> cwpoNoSignature, // do not write Begin, End signatures<br></div><div dir="ltr"> cwpoNoSelf, // enclose in "with LookupRootname do begin"<br></div><div dir="ltr"> cwpoSetParentFirst, // add "SetParentComponent" before setting<br></div><div dir="ltr">properties, default: after<br></div><div dir="ltr"> cwpoSrcCodepageUTF8, // target unit uses $codepage utf-8, aka do not<br></div><div dir="ltr">convert UTF-8 string literals<br></div><div dir="ltr"> cwpoNoWithBlocks // do not use with-do<br></div><div dir="ltr"> );<br></div><div dir="ltr"> TCWPOptions = set of TCWPOption;<br></div><div dir="ltr"><br></div><div dir="ltr"> TCWPChildrenStep = (<br></div><div dir="ltr"> cwpcsCreate,<br></div><div dir="ltr"> cwpcsProperties<br></div><div dir="ltr"> );<br></div><div dir="ltr"><br></div><div dir="ltr"> { TCompWriterPas }<br></div><div dir="ltr"><br></div><div dir="ltr"> TCompWriterPas = class<br></div><div dir="ltr"> private<br></div><div dir="ltr"> FAccessClass: string;<br></div><div dir="ltr"> FAncestor: TPersistent;<br></div><div dir="ltr"> FAncestorPos: Integer;<br></div><div dir="ltr"> FAncestors: TStringList;<br></div><div dir="ltr"> FAssignOp: String;<br></div><div dir="ltr"> FCurIndent: integer;<br></div><div dir="ltr"> FCurrentPos: Integer;<br></div><div dir="ltr"> FDefaultDefineProperties: CodePointer;<br></div><div dir="ltr"> FExecCustomProc: string;<br></div><div dir="ltr"> FExecCustomProcUnit: string;<br></div><div dir="ltr"> FIgnoreChildren: Boolean;<br></div><div dir="ltr"> FIndentStep: integer;<br></div><div dir="ltr"> FLineEnding: string;<br></div><div dir="ltr"> FLookupRoot: TComponent;<br></div><div dir="ltr"> FMaxColumn: integer;<br></div><div dir="ltr"> FNeedAccessClass: boolean;<br></div><div dir="ltr"> FNeededUnits: TStrings;<br></div><div dir="ltr"> FOnDefineProperties: TCWPDefinePropertiesEvent;<br></div><div dir="ltr"> FOnFindAncestor: TCWPFindAncestorEvent;<br></div><div dir="ltr"> FOnGetMethodName: TCWPGetMethodName;<br></div><div dir="ltr"> FOnGetParentProperty: TCWPGetParentPropertyEvent;<br></div><div dir="ltr"> FOnWriteMethodProperty: TWriteMethodPropertyEvent;<br></div><div dir="ltr"> FOnWriteStringProperty: TReadWriteStringPropertyEvent;<br></div><div dir="ltr"> FOptions: TCWPOptions;<br></div><div dir="ltr"> FParent: TComponent;<br></div><div dir="ltr"> FPropPath: string;<br></div><div dir="ltr"> FRoot: TComponent;<br></div><div dir="ltr"> FRootAncestor: TComponent;<br></div><div dir="ltr"> FSignatureBegin: String;<br></div><div dir="ltr"> FSignatureEnd: String;<br></div><div dir="ltr"> FStream: TStream;<br></div><div dir="ltr"> procedure AddToAncestorList(Component: TComponent);<br></div><div dir="ltr"> procedure DetermineAncestor(Component: TComponent);<br></div><div dir="ltr"> procedure SetNeededUnits(const AValue: TStrings);<br></div><div dir="ltr"> procedure SetRoot(const AValue: TComponent);<br></div><div dir="ltr"> procedure WriteComponentData(Instance: TComponent);<br></div><div dir="ltr"> procedure WriteChildren(Component: TComponent; Step: TCWPChildrenStep);<br></div><div dir="ltr"> procedure WriteProperty(Instance: TPersistent; PropInfo: PPropInfo);<br></div><div dir="ltr"> procedure WriteProperties(Instance: TPersistent);<br></div><div dir="ltr"> procedure WriteDefineProperties(Instance: TPersistent);<br></div><div dir="ltr"> procedure WriteCollection(PropName: string; Collection: TCollection);<br></div><div dir="ltr"> function ShortenFloat(s: string): string;<br></div><div dir="ltr"> public<br></div><div dir="ltr"> constructor Create(AStream: TStream);<br></div><div dir="ltr"> destructor Destroy; override;<br></div><div dir="ltr"> // stream a component:<br></div><div dir="ltr"> procedure WriteDescendant(ARoot: TComponent; AAncestor: TComponent =<br></div><div dir="ltr">nil);<br></div><div dir="ltr"> // utility functions:<br></div><div dir="ltr"> procedure WriteComponentCreate(Component: TComponent);<br></div><div dir="ltr"> procedure WriteComponent(Component: TComponent);<br></div><div dir="ltr"> procedure WriteIndent;<br></div><div dir="ltr"> procedure Write(const s: string);<br></div><div dir="ltr"> procedure WriteLn;<br></div><div dir="ltr"> procedure WriteStatement(const s: string);<br></div><div dir="ltr"> procedure WriteAssign(const LHS, RHS: string);<br></div><div dir="ltr"> procedure WriteWithDo(const Expr: string);<br></div><div dir="ltr"> procedure WriteWithEnd;<br></div><div dir="ltr"> function GetComponentPath(Component: TComponent): string;<br></div><div dir="ltr"> function GetBoolLiteral(b: boolean): string;<br></div><div dir="ltr"> function GetCharLiteral(c: integer): string;<br></div><div dir="ltr"> function GetWideCharLiteral(c: integer): string;<br></div><div dir="ltr"> function GetStringLiteral(const s: string): string;<br></div><div dir="ltr"> function GetWStringLiteral(p: PWideChar; Count: integer): string;<br></div><div dir="ltr"> function GetFloatLiteral(const e: Extended): string;<br></div><div dir="ltr"> function GetCurrencyLiteral(const c: currency): string;<br></div><div dir="ltr"> function GetEnumExpr(TypeInfo: PTypeInfo; Value: integer;<br></div><div dir="ltr"> AllowOutOfRange: boolean): string;<br></div><div dir="ltr"> function GetVersionStatement: string;<br></div><div dir="ltr"> function CreatedByAncestor(Component: TComponent): boolean;<br></div><div dir="ltr"> procedure AddNeededUnit(const AnUnitName: string);<br></div><div dir="ltr"> procedure Indent;<br></div><div dir="ltr"> procedure Unindent;<br></div><div dir="ltr"> property Stream: TStream read FStream;<br></div><div dir="ltr"> property Root: TComponent read FRoot write SetRoot;<br></div><div dir="ltr"> property LookupRoot: TComponent read FLookupRoot;<br></div><div dir="ltr"> property Ancestor: TPersistent read FAncestor write FAncestor;<br></div><div dir="ltr"> property RootAncestor: TComponent read FRootAncestor write<br></div><div dir="ltr">FRootAncestor;<br></div><div dir="ltr"> property Parent: TComponent read FParent;<br></div><div dir="ltr"> property OnFindAncestor: TCWPFindAncestorEvent read FOnFindAncestor<br></div><div dir="ltr">write FOnFindAncestor;<br></div><div dir="ltr"> property OnGetMethodName: TCWPGetMethodName read FOnGetMethodName write<br></div><div dir="ltr">FOnGetMethodName;<br></div><div dir="ltr"> property PropertyPath: string read FPropPath;<br></div><div dir="ltr"> property CurIndent: integer read FCurIndent write FCurIndent;<br></div><div dir="ltr"> property IndentStep: integer read FIndentStep write FIndentStep;<br></div><div dir="ltr"> property Options: TCWPOptions read FOptions write FOptions;<br></div><div dir="ltr"> property IgnoreChildren: Boolean read FIgnoreChildren write<br></div><div dir="ltr">FIgnoreChildren;<br></div><div dir="ltr"> property OnGetParentProperty: TCWPGetParentPropertyEvent read<br></div><div dir="ltr">FOnGetParentProperty write FOnGetParentProperty;<br></div><div dir="ltr"> public<br></div><div dir="ltr"> // for custom DefineProperties<br></div><div dir="ltr"> property OnWriteMethodProperty: TWriteMethodPropertyEvent read<br></div><div dir="ltr">FOnWriteMethodProperty write FOnWriteMethodProperty;<br></div><div dir="ltr"> property OnWriteStringProperty: TReadWriteStringPropertyEvent read<br></div><div dir="ltr">FOnWriteStringProperty write FOnWriteStringProperty;<br></div><div dir="ltr"> property OnDefineProperties: TCWPDefinePropertiesEvent read<br></div><div dir="ltr">FOnDefineProperties write FOnDefineProperties;<br></div><div dir="ltr"> public<br></div><div dir="ltr"> // code snippets<br></div><div dir="ltr"> property LineEnding: string read FLineEnding write FLineEnding; //<br></div><div dir="ltr">default: system.LineEnding<br></div><div dir="ltr"> property AssignOp: String read FAssignOp write FAssignOp; // default<br></div><div dir="ltr">CSPDefaultAssignOp;<br></div><div dir="ltr"> property SignatureBegin: String read FSignatureBegin write<br></div><div dir="ltr">FSignatureBegin; // default CSPDefaultSignatureBegin<br></div><div dir="ltr"> property SignatureEnd: String read FSignatureEnd write FSignatureEnd; //<br></div><div dir="ltr">default CSPDefaultSignatureEnd<br></div><div dir="ltr"> property AccessClass: string read FAccessClass<br></div><div dir="ltr"> write FAccessClass; // classname used to access protected TComponent<br></div><div dir="ltr">members like SetChildOrder<br></div><div dir="ltr"> property ExecCustomProc: string read FExecCustomProc write<br></div><div dir="ltr">FExecCustomProc; // default CSPDefaultExecCustomProc<br></div><div dir="ltr"> property ExecCustomProcUnit: string read FExecCustomProcUnit write<br></div><div dir="ltr">FExecCustomProcUnit; // default CSPDefaultExecCustomProcUnit<br></div><div dir="ltr"> property MaxColumn: integer read FMaxColumn write FMaxColumn default<br></div><div dir="ltr">CSPDefaultMaxColumn;<br></div><div dir="ltr"> public<br></div><div dir="ltr"> // set automatically when writing<br></div><div dir="ltr"> property NeedAccessClass: boolean read FNeedAccessClass write<br></div><div dir="ltr">FNeedAccessClass; // some property needed AccessClass<br></div><div dir="ltr"> property NeededUnits: TStrings read FNeededUnits write SetNeededUnits;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure WriteComponentToPasStream(AComponent: TComponent; AStream:<br></div><div dir="ltr">TStream);<br></div><div dir="ltr"><br></div><div dir="ltr">type<br></div><div dir="ltr"> TCWPDefinePropertiesProc = procedure(Sender: TCompWriterPas;<br></div><div dir="ltr"> Instance: TPersistent; const Identifier: string; var Handled: boolean);<br></div><div dir="ltr"><br></div><div dir="ltr">procedure RegisterDefinePropertiesPas(aClass: TPersistentClass;<br></div><div dir="ltr"> const OnDefineProperties: TCWPDefinePropertiesProc);<br></div><div dir="ltr">procedure UnregisterDefinePropertiesPas(<br></div><div dir="ltr"> const OnDefineProperties: TCWPDefinePropertiesProc);<br></div><div dir="ltr">procedure CallDefinePropertiesPas(Writer: TCompWriterPas; Instance:<br></div><div dir="ltr">TPersistent;<br></div><div dir="ltr"> const Identifier: string; var Handled: boolean);<br></div><div dir="ltr"><br></div><div dir="ltr">implementation<br></div><div dir="ltr"><br></div><div dir="ltr">type<br></div><div dir="ltr"> TDefinePropertiesPas = class<br></div><div dir="ltr"> BaseClass: TPersistentClass;<br></div><div dir="ltr"> Event: TCWPDefinePropertiesProc;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr">var<br></div><div dir="ltr"> DefinePropertiesEvents: TObjectList = nil;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure WriteComponentToPasStream(AComponent: TComponent; AStream:<br></div><div dir="ltr">TStream);<br></div><div dir="ltr">var<br></div><div dir="ltr"> Writer: TCompWriterPas;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> Writer:=TCompWriterPas.Create(AStream);<br></div><div dir="ltr"> try<br></div><div dir="ltr"> Writer.WriteDescendant(AComponent);<br></div><div dir="ltr"> finally<br></div><div dir="ltr"> Writer.Free;<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function CompareMethods(const m1, m2: TMethod): boolean;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> Result:=(m1.Code=m2.Code) and (m1.Data=m2.Data);<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure RegisterDefinePropertiesPas(aClass: TPersistentClass;<br></div><div dir="ltr"> const OnDefineProperties: TCWPDefinePropertiesProc);<br></div><div dir="ltr">var<br></div><div dir="ltr"> i, Cnt: Integer;<br></div><div dir="ltr"> E: TDefinePropertiesPas;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> if not Assigned(OnDefineProperties) then<br></div><div dir="ltr"> raise Exception.Create('');<br></div><div dir="ltr"> if not Assigned(aClass) then<br></div><div dir="ltr"> raise Exception.Create('');<br></div><div dir="ltr"> if DefinePropertiesEvents=nil then<br></div><div dir="ltr"> DefinePropertiesEvents:=TObjectList.Create(true);<br></div><div dir="ltr"> Cnt:=DefinePropertiesEvents.Count;<br></div><div dir="ltr"> i:=0;<br></div><div dir="ltr"> while i<Cnt do<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> E:=TDefinePropertiesPas(DefinePropertiesEvents[i]);<br></div><div dir="ltr"> if E.BaseClass.InheritsFrom(aClass) then<br></div><div dir="ltr"> break;<br></div><div dir="ltr"> inc(Cnt);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> E:=TDefinePropertiesPas.Create;<br></div><div dir="ltr"> E.BaseClass:=aClass;<br></div><div dir="ltr"> E.Event:=OnDefineProperties;<br></div><div dir="ltr"> DefinePropertiesEvents.Insert(i,E);<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure UnregisterDefinePropertiesPas(<br></div><div dir="ltr"> const OnDefineProperties: TCWPDefinePropertiesProc);<br></div><div dir="ltr">var<br></div><div dir="ltr"> i: Integer;<br></div><div dir="ltr"> E: TDefinePropertiesPas;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> for i:=DefinePropertiesEvents.Count-1 downto 0 do<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> E:=TDefinePropertiesPas(DefinePropertiesEvents[i]);<br></div><div dir="ltr"> if E.Event=OnDefineProperties then<br></div><div dir="ltr"> DefinePropertiesEvents.Delete(i);<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure CallDefinePropertiesPas(Writer: TCompWriterPas;<br></div><div dir="ltr"> Instance: TPersistent; const Identifier: string; var Handled: boolean);<br></div><div dir="ltr">var<br></div><div dir="ltr"> i: Integer;<br></div><div dir="ltr"> E: TDefinePropertiesPas;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> if DefinePropertiesEvents=nil then exit;<br></div><div dir="ltr"> for i:=0 to DefinePropertiesEvents.Count-1 do begin<br></div><div dir="ltr"> E:=TDefinePropertiesPas(DefinePropertiesEvents[i]);<br></div><div dir="ltr"> if not Instance.InheritsFrom(E.BaseClass) then<br></div><div dir="ltr"> continue;<br></div><div dir="ltr"> E.Event(Writer,Instance,Identifier,Handled);<br></div><div dir="ltr"> if Handled then exit;<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function IsValidUTF8(p: PChar): integer;<br></div><div dir="ltr">var<br></div><div dir="ltr"> c: Char;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> c:=p^;<br></div><div dir="ltr"> if ord(c)<%10000000 then begin<br></div><div dir="ltr"> // regular single byte ASCII character (#0 is a character, this is<br></div><div dir="ltr">Pascal ;)<br></div><div dir="ltr"> Result:=1;<br></div><div dir="ltr"> end else if ord(c)<=%11000001 then begin<br></div><div dir="ltr"> // single byte character, between valid UTF-8 encodings<br></div><div dir="ltr"> // %11000000 and %11000001 map 2 byte to #0..#128, which is invalid and<br></div><div dir="ltr">used for XSS attacks<br></div><div dir="ltr"> Result:=0;<br></div><div dir="ltr"> end else if ord(c)<=%11011111 then begin<br></div><div dir="ltr"> // could be 2 byte character (%110xxxxx %10xxxxxx)<br></div><div dir="ltr"> if ((ord(p[1]) and %11000000) = %10000000) then<br></div><div dir="ltr"> Result:=2<br></div><div dir="ltr"> else<br></div><div dir="ltr"> Result:=0; // missing following bytes<br></div><div dir="ltr"> end<br></div><div dir="ltr"> else if ord(c)<=%11101111 then begin<br></div><div dir="ltr"> // could be 3 byte character (%1110xxxx %10xxxxxx %10xxxxxx)<br></div><div dir="ltr"> if ((ord(p[1]) and %11000000) = %10000000)<br></div><div dir="ltr"> and ((ord(p[2]) and %11000000) = %10000000) then begin<br></div><div dir="ltr"> if (ord(c)=%11100000) and (ord(p[1])<=%10011111) then<br></div><div dir="ltr"> Result:=0; // XSS attack: 3 bytes are mapped to the 1 or 2 byte<br></div><div dir="ltr">codes<br></div><div dir="ltr"> Result:=3;<br></div><div dir="ltr"> end else<br></div><div dir="ltr"> Result:=0; // missing following bytes<br></div><div dir="ltr"> end<br></div><div dir="ltr"> else if ord(c)<=%11110111 then begin<br></div><div dir="ltr"> // could be 4 byte character (%11110xxx %10xxxxxx %10xxxxxx %10xxxxxx)<br></div><div dir="ltr"> if ((ord(p[1]) and %11000000) = %10000000)<br></div><div dir="ltr"> and ((ord(p[2]) and %11000000) = %10000000)<br></div><div dir="ltr"> and ((ord(p[3]) and %11000000) = %10000000) then begin<br></div><div dir="ltr"> if (ord(c)=%11110000) and (ord(p[1])<=%10001111) then<br></div><div dir="ltr"> Result:=0; // XSS attack: 4 bytes are mapped to the 1-3 byte codes<br></div><div dir="ltr"> Result:=4;<br></div><div dir="ltr"> end else<br></div><div dir="ltr"> Result:=0; // missing following bytes<br></div><div dir="ltr"> end<br></div><div dir="ltr"> else begin<br></div><div dir="ltr"> Result:=0;<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function IsValidUTF16(p: PWideChar): integer;<br></div><div dir="ltr">var<br></div><div dir="ltr"> c: WideChar;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> c:=p^;<br></div><div dir="ltr"> if c<=#$DC7F then<br></div><div dir="ltr"> exit(1)<br></div><div dir="ltr"> else if c<=#$DBFF then begin<br></div><div dir="ltr"> c:=p[1];<br></div><div dir="ltr"> if (c>=#$DC00) and (c<=#$DFFF) then<br></div><div dir="ltr"> exit(2)<br></div><div dir="ltr"> else<br></div><div dir="ltr"> exit(0);<br></div><div dir="ltr"> end else if c<=#$Dfff then begin<br></div><div dir="ltr"> exit(0);<br></div><div dir="ltr"> end else<br></div><div dir="ltr"> exit(1);<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr"><br></div><div dir="ltr">type<br></div><div dir="ltr"> TAccessComp = class(TComponent); // to access TComponent protected members<br></div><div dir="ltr"><br></div><div dir="ltr"> { TPosComponent }<br></div><div dir="ltr"><br></div><div dir="ltr"> TPosComponent = class(TObject)<br></div><div dir="ltr"> FPos: Integer;<br></div><div dir="ltr"> FComponent: TComponent;<br></div><div dir="ltr"> constructor Create(APos: Integer; AComponent: TComponent);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr">{ TPosComponent }<br></div><div dir="ltr"><br></div><div dir="ltr">constructor TPosComponent.Create(APos: Integer; AComponent: TComponent);<br></div><div dir="ltr">begin<br></div><div dir="ltr"> FPos:=APos;<br></div><div dir="ltr"> FComponent:=AComponent;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">{ TCompWriterPas }<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.AddToAncestorList(Component: TComponent);<br></div><div dir="ltr">begin<br></div><div dir="ltr"> <br></div><div dir="ltr">FAncestors.AddObject(Component.Name,TPosComponent.Create(FAncestors.Count,Component));<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.DetermineAncestor(Component: TComponent);<br></div><div dir="ltr">var<br></div><div dir="ltr"> i : Integer;<br></div><div dir="ltr"> C: TComponent;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> if Assigned(FAncestors) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> i:=FAncestors.IndexOf(Component.Name);<br></div><div dir="ltr"> if i<0 then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> FAncestor:=nil;<br></div><div dir="ltr"> FAncestorPos:=-1;<br></div><div dir="ltr"> end<br></div><div dir="ltr"> else<br></div><div dir="ltr"> With TPosComponent(FAncestors.Objects[i]) do<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> FAncestor:=FComponent;<br></div><div dir="ltr"> FAncestorPos:=FPos;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> if Assigned(FOnFindAncestor) then<br></div><div dir="ltr"> if (Ancestor=Nil) or (Ancestor is TComponent) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> C:=TComponent(Ancestor);<br></div><div dir="ltr"> FOnFindAncestor(Self,Component,Component.Name,C,FRootAncestor);<br></div><div dir="ltr"> Ancestor:=C;<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.SetNeededUnits(const AValue: TStrings);<br></div><div dir="ltr">begin<br></div><div dir="ltr"> if FNeededUnits=AValue then Exit;<br></div><div dir="ltr"> FNeededUnits.Assign(AValue);<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.SetRoot(const AValue: TComponent);<br></div><div dir="ltr">begin<br></div><div dir="ltr"> FRoot:=AValue;<br></div><div dir="ltr"> FLookupRoot:=FRoot;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteComponentData(Instance: TComponent);<br></div><div dir="ltr">var<br></div><div dir="ltr"> HasAncestor: Boolean;<br></div><div dir="ltr"> SavedPropPath: String;<br></div><div dir="ltr"><br></div><div dir="ltr"> procedure WriteSetParent;<br></div><div dir="ltr"> var<br></div><div dir="ltr"> PropName: String;<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if Parent=nil then exit;<br></div><div dir="ltr"> if Instance.GetParentComponent=nil then exit;<br></div><div dir="ltr"> if CreatedByAncestor(Instance) then begin<br></div><div dir="ltr"> // ancestor creates the component<br></div><div dir="ltr"> // and descendants cannot change parent<br></div><div dir="ltr"> exit;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> PropName:='';<br></div><div dir="ltr"> if Assigned(OnGetParentProperty) then<br></div><div dir="ltr"> OnGetParentProperty(Self,Instance,PropName);<br></div><div dir="ltr"> if PropName=CWPSkipParentName then<br></div><div dir="ltr"> else if PropName<>'' then<br></div><div dir="ltr"> WriteAssign(PropertyPath+PropName,GetComponentPath(Parent))<br></div><div dir="ltr"> else begin<br></div><div dir="ltr"> NeedAccessClass:=true;<br></div><div dir="ltr"> <br></div><div dir="ltr">WriteStatement(AccessClass+'(TComponent('+Instance.Name+')).SetParentComponent('+GetComponentPath(Parent)+');');<br></div><div dir="ltr"> WriteAssign('Parent',GetComponentPath(Parent)); // warleyalex<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr">begin<br></div><div dir="ltr"> HasAncestor := Assigned(Ancestor) and ((Instance = Root) or<br></div><div dir="ltr"> (Instance.ClassType = Ancestor.ClassType));<br></div><div dir="ltr"> SavedPropPath:=FPropPath;<br></div><div dir="ltr"> try<br></div><div dir="ltr"> if Instance=LookupRoot then begin<br></div><div dir="ltr"> //WriteAssign('Name',''''+Instance.Name+'''');<br></div><div dir="ltr"> //WriteChildren(Instance,cwpcsCreate);<br></div><div dir="ltr"><br></div><div dir="ltr"> WriteChildren(Instance,cwpcsCreate);<br></div><div dir="ltr"> WriteStatement('try');<br></div><div dir="ltr"> Indent;<br></div><div dir="ltr"> WriteAssign('Name',''''+Instance.Name+'''');<br></div><div dir="ltr"> end<br></div><div dir="ltr"> else begin<br></div><div dir="ltr"> WriteWithDo(Instance.Name);<br></div><div dir="ltr"> if cwpoNoWithBlocks in Options then<br></div><div dir="ltr"> FPropPath:=GetComponentPath(Instance)+'.';<br></div><div dir="ltr"> if not CreatedByAncestor(Instance) then<br></div><div dir="ltr"> WriteAssign(PropertyPath+'Name',''''+Instance.Name+'''');<br></div><div dir="ltr"> if cwpoSetParentFirst in Options then<br></div><div dir="ltr"> WriteSetParent;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr"> if not (cwpoSetParentFirst in Options) then<br></div><div dir="ltr"> WriteSetParent;<br></div><div dir="ltr"><br></div><div dir="ltr"> WriteProperties(Instance);<br></div><div dir="ltr"><br></div><div dir="ltr"> if not IgnoreChildren then<br></div><div dir="ltr"> WriteChildren(Instance,cwpcsProperties);<br></div><div dir="ltr"> if Instance<>LookupRoot then<br></div><div dir="ltr"> WriteWithEnd;<br></div><div dir="ltr"> finally<br></div><div dir="ltr"> FPropPath:=SavedPropPath;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> if HasAncestor and (Ancestor<>FRootAncestor)<br></div><div dir="ltr"> and (FCurrentPos<>FAncestorPos) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if (Parent=LookupRoot) and not (cwpoNoSelf in Options) then<br></div><div dir="ltr"> <br></div><div dir="ltr">WriteStatement('SetChildOrder('+GetComponentPath(Instance)+','+IntToStr(FCurrentPos)+');')<br></div><div dir="ltr"> else begin<br></div><div dir="ltr"> NeedAccessClass:=true;<br></div><div dir="ltr"> <br></div><div dir="ltr">WriteStatement(AccessClass+'(TComponent('+GetComponentPath(Parent)+')).SetChildOrder('+GetComponentPath(Instance)+','+IntToStr(FCurrentPos)+');');<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> Inc(FCurrentPos);<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteChildren(Component: TComponent;<br></div><div dir="ltr"> Step: TCWPChildrenStep);<br></div><div dir="ltr">var<br></div><div dir="ltr"> SRoot, SRootA, SParent: TComponent;<br></div><div dir="ltr"> SList: TStringList;<br></div><div dir="ltr"> SPos, i, SAncestorPos: Integer;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> // Write children list.<br></div><div dir="ltr"> // While writing children, the ancestor environment must be saved<br></div><div dir="ltr"> // This is recursive...<br></div><div dir="ltr"> SRoot:=FRoot;<br></div><div dir="ltr"> SRootA:=FRootAncestor;<br></div><div dir="ltr"> SList:=FAncestors;<br></div><div dir="ltr"> SPos:=FCurrentPos;<br></div><div dir="ltr"> SAncestorPos:=FAncestorPos;<br></div><div dir="ltr"> SParent:=Parent;<br></div><div dir="ltr"> try<br></div><div dir="ltr"> FAncestors:=Nil;<br></div><div dir="ltr"> FCurrentPos:=0;<br></div><div dir="ltr"> FAncestorPos:=-1;<br></div><div dir="ltr"> FParent:=Component;<br></div><div dir="ltr"> if csInline in Component.ComponentState then<br></div><div dir="ltr"> FRoot:=Component;<br></div><div dir="ltr"> if (FAncestor is TComponent) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> FAncestors:=TStringList.Create;<br></div><div dir="ltr"> if csInline in TComponent(FAncestor).ComponentState then<br></div><div dir="ltr"> FRootAncestor := TComponent(FAncestor);<br></div><div dir="ltr"> TAccessComp(FAncestor).GetChildren(@AddToAncestorList,FRootAncestor);<br></div><div dir="ltr"> FAncestors.Sorted:=True;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> try<br></div><div dir="ltr"> case Step of<br></div><div dir="ltr"> cwpcsCreate:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> TAccessComp(Component).GetChildren(@WriteComponentCreate, FRoot);<br></div><div dir="ltr"> { BeginUpdate block }<br></div><div dir="ltr"> for i:=0 to Component.ComponentCount-1 do<br></div><div dir="ltr"> if Component.Components[i].ClassParent.InheritsFrom(TComponent)<br></div><div dir="ltr">and not<br></div><div dir="ltr"> (Component.Components[i].ClassParent.ClassParent = TComponent)<br></div><div dir="ltr">then<br></div><div dir="ltr"> WriteStatement(Component.Components[i].Name+'.BeginUpdate;');<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> cwpcsProperties:<br></div><div dir="ltr"> TAccessComp(Component).GetChildren(@WriteComponent, FRoot);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> finally<br></div><div dir="ltr"> if Assigned(FAncestor) then<br></div><div dir="ltr"> for i:=0 to FAncestors.Count-1 do<br></div><div dir="ltr"> FAncestors.Objects[i].Free;<br></div><div dir="ltr"> FreeAndNil(FAncestors);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> finally<br></div><div dir="ltr"> FParent:=SParent;<br></div><div dir="ltr"> FAncestors:=SList;<br></div><div dir="ltr"> FRoot:=SRoot;<br></div><div dir="ltr"> FRootAncestor:=SRootA;<br></div><div dir="ltr"> FCurrentPos:=SPos;<br></div><div dir="ltr"> FAncestorPos:=SAncestorPos;<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteProperty(Instance: TPersistent;<br></div><div dir="ltr"> PropInfo: PPropInfo);<br></div><div dir="ltr">type<br></div><div dir="ltr"> TSet = set of 0..31;<br></div><div dir="ltr">var<br></div><div dir="ltr"> PropType, CompType: PTypeInfo;<br></div><div dir="ltr"> ObjValue, AncestorObj: TObject;<br></div><div dir="ltr"> HasAncestor, BoolValue, DefBoolValue: Boolean;<br></div><div dir="ltr"> Int32Value, DefValue: longint;<br></div><div dir="ltr"> PropName, Ident, s, StrValue, DefStrValue, Name, SavedPropPath: String;<br></div><div dir="ltr"> IntToIdentFn: TIntToIdent;<br></div><div dir="ltr"> i, j: Integer;<br></div><div dir="ltr"> Int64Value, DefInt64Value: Int64;<br></div><div dir="ltr"> FloatValue, DefFloatValue: Extended;<br></div><div dir="ltr"> MethodValue, DefMethodValue: TMethod;<br></div><div dir="ltr"> WStrValue, WDefStrValue: WideString;<br></div><div dir="ltr"> UStrValue, UDefStrValue: UnicodeString;<br></div><div dir="ltr"> VarValue, DefVarValue: tvardata;<br></div><div dir="ltr"> aTypeData: PTypeData;<br></div><div dir="ltr"> Component, AncestorComponent: TComponent;<br></div><div dir="ltr"> SavedAncestor: TPersistent;<br></div><div dir="ltr"> IntfValue, AncestorIntf: IInterface;<br></div><div dir="ltr"> CompRef: IInterfaceComponentReference;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> // do not stream properties without getter<br></div><div dir="ltr"> if not Assigned(PropInfo^.GetProc) then<br></div><div dir="ltr"> exit;<br></div><div dir="ltr"><br></div><div dir="ltr"> // properties without setter are only allowed, if they are csSubComponent<br></div><div dir="ltr"> PropType := PropInfo^.PropType;<br></div><div dir="ltr"> if not Assigned(PropInfo^.SetProc) then begin<br></div><div dir="ltr"> if PropType^.Kind<>tkClass then<br></div><div dir="ltr"> exit;<br></div><div dir="ltr"> ObjValue := TObject(GetObjectProp(Instance, PropInfo));<br></div><div dir="ltr"> if not (ObjValue is TComponent) or<br></div><div dir="ltr"> not (csSubComponent in TComponent(ObjValue).ComponentStyle) then<br></div><div dir="ltr"> exit;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr"> { Check if the ancestor can be used }<br></div><div dir="ltr"> HasAncestor := Assigned(Ancestor) and ((Instance = Root) or<br></div><div dir="ltr"> (Instance.ClassType = Ancestor.ClassType));<br></div><div dir="ltr"> PropName:=FPropPath + PropInfo^.Name;<br></div><div dir="ltr"> {$IFDEF VerboseCompWriterPas}<br></div><div dir="ltr"> debugln(['TWriter.WriteProperty PropName="',PropName,'"<br></div><div dir="ltr">TypeName=',PropType^.Name,'<br></div><div dir="ltr">Kind=',GetEnumName(TypeInfo(TTypeKind),ord(PropType^.Kind)),'<br></div><div dir="ltr">HasAncestor=',HasAncestor]);<br></div><div dir="ltr"> {$ENDIF}<br></div><div dir="ltr"><br></div><div dir="ltr"> case PropType^.Kind of<br></div><div dir="ltr"> tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> Int32Value := GetOrdProp(Instance, PropInfo);<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> DefValue := GetOrdProp(Ancestor, PropInfo)<br></div><div dir="ltr"> else<br></div><div dir="ltr"> DefValue := PPropInfo(PropInfo)^.Default;<br></div><div dir="ltr"> //debugln([PropInfo^.Name,', HasAncestor=',HasAncestor,',<br></div><div dir="ltr">Value=',Int32Value,', Default=',DefValue]);<br></div><div dir="ltr"> if (Int32Value <> DefValue) or (DefValue=longint($80000000)) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> case PropType^.Kind of<br></div><div dir="ltr"> tkInteger:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> // Check if this integer has a string identifier<br></div><div dir="ltr"> IntToIdentFn := FindIntToIdent(PropInfo^.PropType);<br></div><div dir="ltr"> Ident:='';<br></div><div dir="ltr"> if Assigned(IntToIdentFn) and IntToIdentFn(Int32Value,<br></div><div dir="ltr">Ident) then<br></div><div dir="ltr"> // Integer with a custom identifier<br></div><div dir="ltr"> // ToDo: check if this is an actual Pascal constant and<br></div><div dir="ltr">remember the unit<br></div><div dir="ltr"> WriteAssign(PropName,Ident)<br></div><div dir="ltr"> else begin<br></div><div dir="ltr"> // Integer has to be written just as number<br></div><div dir="ltr"> case PropType^.Name of<br></div><div dir="ltr"> 'ByteBool':<br></div><div dir="ltr">WriteAssign(PropName,GetBoolLiteral(ByteBool(Int32Value)));<br></div><div dir="ltr"> 'WordBool':<br></div><div dir="ltr">WriteAssign(PropName,GetBoolLiteral(WordBool(Int32Value)));<br></div><div dir="ltr"> 'LongBool':<br></div><div dir="ltr">WriteAssign(PropName,GetBoolLiteral(LongBool(Int32Value)));<br></div><div dir="ltr"> else<br></div><div dir="ltr"> aTypeData:=GetTypeData(PropInfo^.PropType);<br></div><div dir="ltr"> if aTypeData^.MinValue>=0 then<br></div><div dir="ltr"> WriteAssign(PropName,IntToStr(longword(Int32Value)))<br></div><div dir="ltr"> else<br></div><div dir="ltr"> WriteAssign(PropName,IntToStr(Int32Value));<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> tkChar:<br></div><div dir="ltr"> WriteAssign(PropName,GetCharLiteral(Int32Value));<br></div><div dir="ltr"> tkWChar:<br></div><div dir="ltr"> WriteAssign(PropName,GetWideCharLiteral(Int32Value));<br></div><div dir="ltr"> tkSet:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> s:='';<br></div><div dir="ltr"> CompType:=GetTypeData(PropType)^.CompType;<br></div><div dir="ltr"> i:=0;<br></div><div dir="ltr"> while i<32 do<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if i in TSet(Int32Value) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if s<>'' then s:=s+',';<br></div><div dir="ltr"> // ToDo: store needed unit<br></div><div dir="ltr"> s:=s+GetEnumExpr(CompType, i,false);<br></div><div dir="ltr"> j:=i;<br></div><div dir="ltr"> while (i<31) and (byte(i+1) in TSet(Int32Value)) do<br></div><div dir="ltr"> inc(i);<br></div><div dir="ltr"> if i>j then<br></div><div dir="ltr"> s:=s+'..'+GetEnumExpr(CompType, i,false);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> inc(i);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> WriteAssign(PropName,'['+s+']');<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> tkEnumeration:<br></div><div dir="ltr"> // ToDo: store needed unit<br></div><div dir="ltr"> WriteAssign(PropName,GetEnumExpr(PropType, Int32Value,true));<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> tkFloat:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> FloatValue := GetFloatProp(Instance, PropInfo);<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> DefFloatValue := GetFloatProp(Ancestor, PropInfo)<br></div><div dir="ltr"> else<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> DefValue :=PropInfo^.Default;<br></div><div dir="ltr"> DefFloatValue:=PSingle(@PropInfo^.Default)^;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> if (FloatValue<>DefFloatValue) or (DefValue=longint($80000000)) then<br></div><div dir="ltr"> WriteAssign(PropName,GetFloatLiteral(FloatValue));<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> tkMethod:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> MethodValue := GetMethodProp(Instance, PropInfo);<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> DefMethodValue := GetMethodProp(Ancestor, PropInfo)<br></div><div dir="ltr"> else begin<br></div><div dir="ltr"> DefMethodValue.Data := nil;<br></div><div dir="ltr"> DefMethodValue.Code := nil;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr"> //debugln(['TCompWriterPas.WriteProperty ',dbgs(MethodValue.Data),'<br></div><div dir="ltr">',dbgs(MethodValue.Code),' ',dbgs(DefMethodValue.Data),'<br></div><div dir="ltr">',dbgs(DefMethodValue.Code)]);<br></div><div dir="ltr"> if Assigned(OnGetMethodName) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if (MethodValue.Code <> DefMethodValue.Code) or<br></div><div dir="ltr"> (MethodValue.Data <> DefMethodValue.Data) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> OnGetMethodName(Self,Instance,PropInfo,Ident);<br></div><div dir="ltr"> s:='';<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> OnGetMethodName(Self,Ancestor,PropInfo,s);<br></div><div dir="ltr"> if Ident<>s then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if Ident='' then<br></div><div dir="ltr"> WriteAssign(PropName,'nil')<br></div><div dir="ltr"> else<br></div><div dir="ltr"> // ToDo: check nameclash of Ident with current with-do block<br></div><div dir="ltr"> WriteAssign(PropName,'@'+Ident);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end else begin<br></div><div dir="ltr"> if (MethodValue.Code <> DefMethodValue.Code) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if not Assigned(MethodValue.Code) then<br></div><div dir="ltr"> Ident:=''<br></div><div dir="ltr"> else<br></div><div dir="ltr"> Ident:=FLookupRoot.MethodName(MethodValue.Code);<br></div><div dir="ltr"> if Ident='' then<br></div><div dir="ltr"> WriteAssign(PropName,'nil')<br></div><div dir="ltr"> else<br></div><div dir="ltr"> // ToDo: check nameclash of Ident with current with-do block<br></div><div dir="ltr"> WriteAssign(PropName,'@'+Ident);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> tkSString, tkLString, tkAString:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> StrValue := GetStrProp(Instance, PropInfo);<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> DefStrValue := GetStrProp(Ancestor, PropInfo)<br></div><div dir="ltr"> else<br></div><div dir="ltr"> SetLength(DefStrValue, 0);<br></div><div dir="ltr"><br></div><div dir="ltr"> if StrValue <> DefStrValue then<br></div><div dir="ltr"> WriteAssign(PropName,GetStringLiteral(StrValue));<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> tkWString:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> WStrValue := GetWideStrProp(Instance, PropInfo);<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> WDefStrValue := GetWideStrProp(Ancestor, PropInfo)<br></div><div dir="ltr"> else<br></div><div dir="ltr"> WDefStrValue := '';<br></div><div dir="ltr"><br></div><div dir="ltr"> if WStrValue <> WDefStrValue then<br></div><div dir="ltr"> <br></div><div dir="ltr">WriteAssign(PropName,GetWStringLiteral(PWideChar(WStrValue),length(WStrValue)));<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> tkUString:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> UStrValue := GetUnicodeStrProp(Instance, PropInfo);<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> UDefStrValue := GetUnicodeStrProp(Ancestor, PropInfo)<br></div><div dir="ltr"> else<br></div><div dir="ltr"> SetLength(UDefStrValue, 0);<br></div><div dir="ltr"><br></div><div dir="ltr"> if UStrValue <> UDefStrValue then<br></div><div dir="ltr"> <br></div><div dir="ltr">WriteAssign(PropName,GetWStringLiteral(PWideChar(UStrValue),length(UStrValue)));<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> tkVariant:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> // Ensure that a Variant manager is installed<br></div><div dir="ltr"> if not Assigned(VarClearProc) then<br></div><div dir="ltr"> raise EWriteError.Create(SErrNoVariantSupport);<br></div><div dir="ltr"><br></div><div dir="ltr"> VarValue := tvardata(GetVariantProp(Instance, PropInfo));<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> DefVarValue := tvardata(GetVariantProp(Ancestor, PropInfo))<br></div><div dir="ltr"> else<br></div><div dir="ltr"> FillChar(DefVarValue,sizeof(DefVarValue),0);<br></div><div dir="ltr"><br></div><div dir="ltr"> if (CompareByte(VarValue,DefVarValue,sizeof(VarValue)) <> 0) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> // can't use variant() typecast, pulls in variants unit<br></div><div dir="ltr"> case VarValue.vtype of<br></div><div dir="ltr"> varsmallint :<br></div><div dir="ltr">WriteAssign(PropName,'SmallInt('+IntToStr(VarValue.vsmallint)+')');<br></div><div dir="ltr"> varinteger :<br></div><div dir="ltr">WriteAssign(PropName,'LongInt('+IntToStr(VarValue.vinteger)+')');<br></div><div dir="ltr"> varsingle :<br></div><div dir="ltr">WriteAssign(PropName,'Single('+GetFloatLiteral(VarValue.vsingle)+')');<br></div><div dir="ltr"> vardouble :<br></div><div dir="ltr">WriteAssign(PropName,'Double('+GetFloatLiteral(VarValue.vdouble)+')');<br></div><div dir="ltr"> vardate :<br></div><div dir="ltr">WriteAssign(PropName,'TDateTime('+GetFloatLiteral(VarValue.vdate)+')');<br></div><div dir="ltr"> varcurrency :<br></div><div dir="ltr">WriteAssign(PropName,'Currency('+GetCurrencyLiteral(VarValue.vcurrency)+')');<br></div><div dir="ltr"> //varolestr : (volestr : pwidechar);<br></div><div dir="ltr"> //vardispatch : (vdispatch : pointer);<br></div><div dir="ltr"> //varerror : (verror : hresult);<br></div><div dir="ltr"> varboolean :<br></div><div dir="ltr">WriteAssign(PropName,GetBoolLiteral(VarValue.vboolean));<br></div><div dir="ltr"> //varunknown : (vunknown : pointer);<br></div><div dir="ltr"> // vardecimal : ( : );<br></div><div dir="ltr"> varshortint :<br></div><div dir="ltr">WriteAssign(PropName,'ShortInt('+IntToStr(VarValue.vshortint)+')');<br></div><div dir="ltr"> varbyte :<br></div><div dir="ltr">WriteAssign(PropName,'Byte('+IntToStr(VarValue.vbyte)+')');<br></div><div dir="ltr"> varword :<br></div><div dir="ltr">WriteAssign(PropName,'Word('+IntToStr(VarValue.vword)+')');<br></div><div dir="ltr"> varlongword :<br></div><div dir="ltr">WriteAssign(PropName,'LongWord('+IntToStr(VarValue.vlongword)+')');<br></div><div dir="ltr"> varint64 :<br></div><div dir="ltr">WriteAssign(PropName,'Int64('+IntToStr(VarValue.vint64)+')');<br></div><div dir="ltr"> varqword :<br></div><div dir="ltr">WriteAssign(PropName,'QWord('+IntToStr(VarValue.vqword)+')');<br></div><div dir="ltr"> // duplicate: varword64<br></div><div dir="ltr"> varstring :<br></div><div dir="ltr">WriteAssign(PropName,GetStringLiteral(AnsiString(VarValue.vstring)));<br></div><div dir="ltr"> //varany : (vany : pointer);<br></div><div dir="ltr"> //vararray : (varray : pvararray);<br></div><div dir="ltr"> //varbyref : (vpointer : pointer);<br></div><div dir="ltr"> //varrecord : (vrecord : pointer;precinfo : pointer);<br></div><div dir="ltr"> else<br></div><div dir="ltr"> {$IFDEF VerboseCompWriterPas}<br></div><div dir="ltr"> debugln(['TCompWriterPas.WriteProperty Property="',PropName,'"<br></div><div dir="ltr">Kind=',PropType^.Kind,' vtype=',VarValue.vtype]);<br></div><div dir="ltr"> raise EWriteError.Create('proptype not supported:<br></div><div dir="ltr">'+GetEnumName(TypeInfo(PropType^.Kind),ord(PropType^.Kind))+'<br></div><div dir="ltr">vtype='+dbgs(VarValue.vtype));<br></div><div dir="ltr"> {$ENDIF}<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> //ToDo WriteVariant(pvariant(@VarValue)^);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> tkClass:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> ObjValue := TObject(GetObjectProp(Instance, PropInfo));<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> AncestorObj := TObject(GetObjectProp(Ancestor, PropInfo));<br></div><div dir="ltr"> if (AncestorObj is TComponent) and<br></div><div dir="ltr"> (ObjValue is TComponent) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> //debugln(['TWriter.WriteProperty<br></div><div dir="ltr">AncestorObj=',TComponent(AncestorObj).Name,'<br></div><div dir="ltr">OwnerFit=',TComponent(AncestorObj).Owner = FRootAncestor,'<br></div><div dir="ltr">',TComponent(ObjValue).Name,' OwnerFit=',TComponent(ObjValue).Owner =<br></div><div dir="ltr">Root]);<br></div><div dir="ltr"> if (AncestorObj<>ObjValue) and<br></div><div dir="ltr"> (TComponent(AncestorObj).Owner = FRootAncestor) and<br></div><div dir="ltr"> (TComponent(ObjValue).Owner = Root) and<br></div><div dir="ltr"> <br></div><div dir="ltr">SameText(TComponent(AncestorObj).Name,TComponent(ObjValue).Name) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> // value is a component, and it is the same as in the ancestor<br></div><div dir="ltr"> // Note: a descendant has new instances with same names<br></div><div dir="ltr"> AncestorObj := ObjValue;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end else<br></div><div dir="ltr"> AncestorObj := nil;<br></div><div dir="ltr"><br></div><div dir="ltr"> if not Assigned(ObjValue) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if ObjValue <> AncestorObj then<br></div><div dir="ltr"> WriteAssign(PropName,'Nil');<br></div><div dir="ltr"> end<br></div><div dir="ltr"> else if ObjValue.InheritsFrom(TPersistent) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> // Subcomponents are streamed the same way as persistents<br></div><div dir="ltr"> if ObjValue.InheritsFrom(TComponent)<br></div><div dir="ltr"> and ((not (csSubComponent in<br></div><div dir="ltr">TComponent(ObjValue).ComponentStyle))<br></div><div dir="ltr"> or ((TComponent(ObjValue).Owner<>Instance) and<br></div><div dir="ltr">(TComponent(ObjValue).Owner<>Nil))) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> Component := TComponent(ObjValue);<br></div><div dir="ltr"> if (ObjValue <> AncestorObj)<br></div><div dir="ltr"> and not (csTransient in Component.ComponentStyle) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> // set property value<br></div><div dir="ltr"> Name:=GetComponentPath(Component);<br></div><div dir="ltr"> if Name='' then<br></div><div dir="ltr"> raise EWriteError.Create('cannot write property<br></div><div dir="ltr">"'+DbgSName(Instance)+'.'+PropName+'"');<br></div><div dir="ltr"> WriteAssign(PropName,Name);<br></div><div dir="ltr"> end; //(ObjValue <> AncestorObj)<br></div><div dir="ltr"> end // ObjValue.InheritsFrom(TComponent)<br></div><div dir="ltr"> else<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> // keep property value, set sub properties recursively with full<br></div><div dir="ltr">path<br></div><div dir="ltr"> // e.g. Font.Size:=5;<br></div><div dir="ltr"> SavedAncestor := Ancestor;<br></div><div dir="ltr"> SavedPropPath := FPropPath;<br></div><div dir="ltr"> try<br></div><div dir="ltr"> FPropPath := FPropPath + PPropInfo(PropInfo)^.Name + '.';<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> Ancestor := TPersistent(GetObjectProp(Ancestor, PropInfo));<br></div><div dir="ltr"> WriteProperties(TPersistent(ObjValue));<br></div><div dir="ltr"> finally<br></div><div dir="ltr"> Ancestor := SavedAncestor;<br></div><div dir="ltr"> FPropPath := SavedPropPath;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> if ObjValue.InheritsFrom(TCollection) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if (not HasAncestor) or (not<br></div><div dir="ltr">CollectionsEqual(TCollection(ObjValue),<br></div><div dir="ltr"> TCollection(GetObjectProp(Ancestor,<br></div><div dir="ltr">PropInfo)),Root,RootAncestor)) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> // create collection items<br></div><div dir="ltr"> SavedPropPath := FPropPath;<br></div><div dir="ltr"> try<br></div><div dir="ltr"> if cwpoNoWithBlocks in Options then<br></div><div dir="ltr"> FPropPath:=PropName+'.'<br></div><div dir="ltr"> else<br></div><div dir="ltr"> FPropPath:='';<br></div><div dir="ltr"> WriteCollection(PropName,TCollection(ObjValue));<br></div><div dir="ltr"> finally<br></div><div dir="ltr"> FPropPath := SavedPropPath;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end // TCollection<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end; // Inheritsfrom(TPersistent)<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> tkInt64, tkQWord:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> Int64Value := GetInt64Prop(Instance, PropInfo);<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> DefInt64Value := GetInt64Prop(Ancestor, PropInfo)<br></div><div dir="ltr"> else<br></div><div dir="ltr"> DefInt64Value := 0;<br></div><div dir="ltr"> if Int64Value <> DefInt64Value then<br></div><div dir="ltr"> if PropType^.Kind=tkInt64 then<br></div><div dir="ltr"> WriteAssign(PropName,IntToStr(Int64Value))<br></div><div dir="ltr"> else<br></div><div dir="ltr"> WriteAssign(PropName,IntToStr(QWord(Int64Value)));<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> tkBool:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> BoolValue := GetOrdProp(Instance, PropInfo)<>0;<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> DefBoolValue := GetOrdProp(Ancestor, PropInfo)<>0<br></div><div dir="ltr"> else<br></div><div dir="ltr"> DefBoolValue := PropInfo^.Default<>0;<br></div><div dir="ltr"> DefValue:=PropInfo^.Default;<br></div><div dir="ltr"> //debugln([PropInfo^.Name,', HasAncestor=',HasAncestor,',<br></div><div dir="ltr">BoolValue=',BoolValue,', DefBoolValue=',DefBoolValue,' Default=',DefValue]);<br></div><div dir="ltr"> if (BoolValue<>DefBoolValue) or (DefValue=longint($80000000)) then<br></div><div dir="ltr"> WriteAssign(PropName,GetBoolLiteral(BoolValue));<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> tkInterface:<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> IntfValue := GetInterfaceProp(Instance, PropInfo);<br></div><div dir="ltr"> if not Assigned(IntfValue) then<br></div><div dir="ltr"> WriteAssign(PropName,'Nil')<br></div><div dir="ltr"> else if Supports(IntfValue, IInterfaceComponentReference, CompRef)<br></div><div dir="ltr">then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> Component := CompRef.GetComponent;<br></div><div dir="ltr"> AncestorComponent := nil;<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> AncestorIntf := GetInterfaceProp(Instance, PropInfo);<br></div><div dir="ltr"> if Supports(AncestorIntf, IInterfaceComponentReference, CompRef)<br></div><div dir="ltr">then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> AncestorComponent := CompRef.GetComponent;<br></div><div dir="ltr"> if (AncestorComponent<>Component) and<br></div><div dir="ltr"> (AncestorComponent.Owner = FRootAncestor) and<br></div><div dir="ltr"> (Component.Owner = Root) and<br></div><div dir="ltr"> SameText(AncestorComponent.Name,Component.Name) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> // value is a component, and it is the same as in the<br></div><div dir="ltr">ancestor<br></div><div dir="ltr"> // Note: a descendant has new instances with same names<br></div><div dir="ltr"> AncestorComponent := Component;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr"> if Component<>AncestorComponent then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> Name:=GetComponentPath(Component);<br></div><div dir="ltr"> if Name='' then<br></div><div dir="ltr"> raise EWriteError.Create('cannot write property<br></div><div dir="ltr">"'+DbgSName(Instance)+'.'+PropName+'"');<br></div><div dir="ltr"> WriteAssign(PropName,Name);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end else<br></div><div dir="ltr"> raise EWriteError.Create('interface property "'+PropName+'" does<br></div><div dir="ltr">not support IInterfaceComponentReference');<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> else<br></div><div dir="ltr"> {$IFDEF VerboseCompWriterPas}<br></div><div dir="ltr"> debugln(['TCompWriterPas.WriteProperty Property="',PropName,'"<br></div><div dir="ltr">Kind=',PropType^.Kind]);<br></div><div dir="ltr"> raise EWriteError.Create('proptype not supported:<br></div><div dir="ltr">'+GetEnumName(TypeInfo(PropType^.Kind),ord(PropType^.Kind)));<br></div><div dir="ltr"> {$ENDIF}<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteProperties(Instance: TPersistent);<br></div><div dir="ltr">var<br></div><div dir="ltr"> PropCount, i: integer;<br></div><div dir="ltr"> PropList: PPropList;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> PropCount:=GetPropList(Instance,PropList);<br></div><div dir="ltr"> if PropCount>0 then<br></div><div dir="ltr"> try<br></div><div dir="ltr"> for i := 0 to PropCount-1 do<br></div><div dir="ltr"> if IsStoredProp(Instance,PropList^[i]) then<br></div><div dir="ltr"> WriteProperty(Instance,PropList^[i]);<br></div><div dir="ltr"> finally<br></div><div dir="ltr"> Freemem(PropList);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> WriteDefineProperties(Instance);<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteDefineProperties(Instance: TPersistent);<br></div><div dir="ltr">var<br></div><div dir="ltr"> Col: Integer;<br></div><div dir="ltr"> InLit, NeedComma: boolean;<br></div><div dir="ltr"> InstancePath: String;<br></div><div dir="ltr"><br></div><div dir="ltr"> function CheckCol(aCol: integer): boolean;<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if (Col<=CurIndent+1) or (aCol<=MaxColumn) then exit(true);<br></div><div dir="ltr"> Result:=false;<br></div><div dir="ltr"> if NeedComma then<br></div><div dir="ltr"> Write(',');<br></div><div dir="ltr"> WriteLn;<br></div><div dir="ltr"> WriteIndent;<br></div><div dir="ltr"> Col:=CurIndent+1;<br></div><div dir="ltr"> NeedComma:=false;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr"> function GetPath: string;<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if InstancePath='' then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if PropertyPath<>'' then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> InstancePath:=PropertyPath;<br></div><div dir="ltr"> Delete(InstancePath,length(InstancePath),1); // chomp '.'<br></div><div dir="ltr"> end<br></div><div dir="ltr"> else if Instance is TComponent then<br></div><div dir="ltr"> InstancePath:=GetComponentPath(TComponent(Instance))<br></div><div dir="ltr"> else<br></div><div dir="ltr"> InstancePath:='';<br></div><div dir="ltr"> if InstancePath='' then<br></div><div dir="ltr"> raise EWriteError.Create('cannot write DefineProperties of<br></div><div dir="ltr">"'+DbgSName(Instance)+'"');<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> Result:=InstancePath;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr">var<br></div><div dir="ltr"> HasAncestor, Handled: Boolean;<br></div><div dir="ltr"> DefValue, Value: LongInt;<br></div><div dir="ltr"> aStream: TMemoryStream;<br></div><div dir="ltr"> BinWriter: TWriter;<br></div><div dir="ltr"> s: String;<br></div><div dir="ltr"> p: PChar;<br></div><div dir="ltr"> c: Char;<br></div><div dir="ltr"> i: Integer;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> InstancePath:='';<br></div><div dir="ltr"><br></div><div dir="ltr"> Handled:=false;<br></div><div dir="ltr"> if Assigned(OnDefineProperties) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> s:=GetPath;<br></div><div dir="ltr"> OnDefineProperties(Self,Instance,s,Handled);<br></div><div dir="ltr"> if Handled then exit;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> if DefinePropertiesEvents<>nil then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> s:=GetPath;<br></div><div dir="ltr"> CallDefinePropertiesPas(Self,Instance,s,Handled);<br></div><div dir="ltr"> if Handled then exit;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr"> if Instance is TComponent then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> HasAncestor := Assigned(Ancestor) and ((Instance = Root) or<br></div><div dir="ltr"> (Instance.ClassType = Ancestor.ClassType));<br></div><div dir="ltr"> if HasAncestor then<br></div><div dir="ltr"> DefValue := TComponent(Ancestor).DesignInfo<br></div><div dir="ltr"> else<br></div><div dir="ltr"> DefValue := 0;<br></div><div dir="ltr"> Value:=TComponent(Instance).DesignInfo;<br></div><div dir="ltr"> if Value<>DefValue then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> // Note: DesignInfo contains Left/Top. On BigEndian systems the order<br></div><div dir="ltr"> // is reversed, which is already handled in<br></div><div dir="ltr">TComponent.DefineProperties<br></div><div dir="ltr"> // -> it is the same longint value on Little and BigEndian system<br></div><div dir="ltr"> s:=GetPath;<br></div><div dir="ltr"> if s<>'' then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if SameText(s,'Self') then<br></div><div dir="ltr"> s:=''<br></div><div dir="ltr"> else<br></div><div dir="ltr"> s:=s+'.';<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> WriteAssign(s + 'DesignInfo',IntToStr(Value));<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr"> if<br></div><div dir="ltr">TMethod(@TAccessComp(Instance).DefineProperties).Code<>FDefaultDefineProperties<br></div><div dir="ltr"> then begin<br></div><div dir="ltr"> // this class has overriden DefineProperties<br></div><div dir="ltr"> aStream:=TMemoryStream.Create;<br></div><div dir="ltr"> BinWriter:=TWriter.Create(aStream,1024);<br></div><div dir="ltr"> try<br></div><div dir="ltr"> BinWriter.Root:=Root;<br></div><div dir="ltr"> BinWriter.RootAncestor:=RootAncestor;<br></div><div dir="ltr"> BinWriter.Ancestor:=Ancestor;<br></div><div dir="ltr"> BinWriter.IgnoreChildren:=IgnoreChildren;<br></div><div dir="ltr"> BinWriter.OnWriteMethodProperty:=OnWriteMethodProperty;<br></div><div dir="ltr"> BinWriter.OnWriteStringProperty:=OnWriteStringProperty;<br></div><div dir="ltr"> TAccessComp(Instance).DefineProperties(BinWriter);<br></div><div dir="ltr"> BinWriter.WriteListEnd;<br></div><div dir="ltr"> FreeAndNil(BinWriter); // flush buffer to stream<br></div><div dir="ltr"> if aStream.Size>1 then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> WriteIndent;<br></div><div dir="ltr"> s:=GetPath;<br></div><div dir="ltr"> s:='Picture.LoadFromFile(URL);';<br></div><div dir="ltr"> Write(s);<br></div><div dir="ltr"> WriteLn;<br></div><div dir="ltr"> Unindent;<br></div><div dir="ltr"> Unindent;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> finally<br></div><div dir="ltr"> BinWriter.Free;<br></div><div dir="ltr"> aStream.Free;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr"> // this class has overriden DefineProperties<br></div><div dir="ltr"> (*<br></div><div dir="ltr"> aStream:=TMemoryStream.Create;<br></div><div dir="ltr"> BinWriter:=TWriter.Create(aStream,1024);<br></div><div dir="ltr"> try<br></div><div dir="ltr"> BinWriter.Root:=Root;<br></div><div dir="ltr"> BinWriter.RootAncestor:=RootAncestor;<br></div><div dir="ltr"> BinWriter.Ancestor:=Ancestor;<br></div><div dir="ltr"> BinWriter.IgnoreChildren:=IgnoreChildren;<br></div><div dir="ltr"> BinWriter.OnWriteMethodProperty:=OnWriteMethodProperty;<br></div><div dir="ltr"> BinWriter.OnWriteStringProperty:=OnWriteStringProperty;<br></div><div dir="ltr"> TAccessComp(Instance).DefineProperties(BinWriter);<br></div><div dir="ltr"> BinWriter.WriteListEnd;<br></div><div dir="ltr"> FreeAndNil(BinWriter); // flush buffer to stream<br></div><div dir="ltr"> if aStream.Size>1 then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> WriteIndent;<br></div><div dir="ltr"> s:=GetPath;<br></div><div dir="ltr"> s:=ExecCustomProc+'('+s+',[';<br></div><div dir="ltr"> Write(s);<br></div><div dir="ltr"> AddNeededUnit(ExecCustomProcUnit);<br></div><div dir="ltr"> Col:=CurIndent+length(s)+1;<br></div><div dir="ltr"> Indent;<br></div><div dir="ltr"> NeedComma:=false;<br></div><div dir="ltr"> CheckCol(Col);<br></div><div dir="ltr"> InLit:=false;<br></div><div dir="ltr"> p:=PChar(aStream.Memory);<br></div><div dir="ltr"> for i:=0 to aStream.Size-1 do<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> c:=p^;<br></div><div dir="ltr"> if c in [#32..#126] then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if (not InLit) or (Col+2>MaxColumn) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if InLit then<br></div><div dir="ltr"> Write('''');<br></div><div dir="ltr"> CheckCol(Col+3);<br></div><div dir="ltr"> InLit:=true;<br></div><div dir="ltr"> Write('''');<br></div><div dir="ltr"> inc(Col);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> Write(c);<br></div><div dir="ltr"> inc(Col);<br></div><div dir="ltr"> NeedComma:=true;<br></div><div dir="ltr"> end else begin<br></div><div dir="ltr"> if InLit then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> Write('''');<br></div><div dir="ltr"> inc(Col);<br></div><div dir="ltr"> InLit:=false;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> s:='#'+IntToStr(ord(c));<br></div><div dir="ltr"> CheckCol(Col+length(s));<br></div><div dir="ltr"> Write(s);<br></div><div dir="ltr"> inc(Col,length(s));<br></div><div dir="ltr"> NeedComma:=true;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> inc(p);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> if InLit then<br></div><div dir="ltr"> Write('''');<br></div><div dir="ltr"> Write(']);');<br></div><div dir="ltr"> WriteLn;<br></div><div dir="ltr"> Unindent;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> finally<br></div><div dir="ltr"> BinWriter.Free;<br></div><div dir="ltr"> aStream.Free;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> *)<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteCollection(PropName: string;<br></div><div dir="ltr"> Collection: TCollection);<br></div><div dir="ltr">var<br></div><div dir="ltr"> i: Integer;<br></div><div dir="ltr"> Item: TCollectionItem;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> WriteStatement(PropName+'.Clear;');<br></div><div dir="ltr"> for i:=0 to Collection.Count-1 do<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> Item:=Collection.Items[i];<br></div><div dir="ltr"> WriteWithDo(Item.ClassName+'('+PropName+'.Add)');<br></div><div dir="ltr"> WriteProperties(Item);<br></div><div dir="ltr"> WriteWithEnd;<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function TCompWriterPas.GetComponentPath(Component: TComponent): string;<br></div><div dir="ltr">var<br></div><div dir="ltr"> Name: String;<br></div><div dir="ltr"> C: TComponent;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> if Component=nil then<br></div><div dir="ltr"> Result:='Nil'<br></div><div dir="ltr"> else if Component=LookupRoot then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if cwpoNoSelf in Options then<br></div><div dir="ltr"> Result:=LookupRoot.Name<br></div><div dir="ltr"> else<br></div><div dir="ltr"> Result:='Self';<br></div><div dir="ltr"> end<br></div><div dir="ltr"> else begin<br></div><div dir="ltr"> Name:= '';<br></div><div dir="ltr"> C:=Component;<br></div><div dir="ltr"> While (C<>Nil) do<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if (Name<>'') Then<br></div><div dir="ltr"> Name:='.'+Name;<br></div><div dir="ltr"> if C.Owner = LookupRoot then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> Name := C.Name+Name;<br></div><div dir="ltr"> if (cwpoNoWithBlocks in Options) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if cwpoNoSelf in Options then<br></div><div dir="ltr"> Name := C.Owner.Name+'.'+Name;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> break;<br></div><div dir="ltr"> end<br></div><div dir="ltr"> else if C = LookupRoot then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if cwpoNoSelf in Options then<br></div><div dir="ltr"> Name := C.Name+Name<br></div><div dir="ltr"> else<br></div><div dir="ltr"> Name := 'Self'+Name;<br></div><div dir="ltr"> break;<br></div><div dir="ltr"> end else if C.Name='' then<br></div><div dir="ltr"> exit('');<br></div><div dir="ltr"> Name:=C.Name+Name;<br></div><div dir="ltr"> // ToDo: store used unit<br></div><div dir="ltr"> C:=C.Owner;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> Result:=Name;<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function TCompWriterPas.GetBoolLiteral(b: boolean): string;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> if b then<br></div><div dir="ltr"> Result:='True'<br></div><div dir="ltr"> else<br></div><div dir="ltr"> Result:='False';<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function TCompWriterPas.GetCharLiteral(c: integer): string;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> case c of<br></div><div dir="ltr"> 32..126: Result:=''''+chr(c)+'''';<br></div><div dir="ltr"> else Result:='#'+IntToStr(c);<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function TCompWriterPas.GetWideCharLiteral(c: integer): string;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> case c of<br></div><div dir="ltr"> 32..126:<br></div><div dir="ltr"> Result:=''''+Chr(c)+'''';<br></div><div dir="ltr"> 0..31,127..255,$D800..$DFFF:<br></div><div dir="ltr"> Result:='#'+IntToStr(c);<br></div><div dir="ltr"> else<br></div><div dir="ltr"> if cwpoSrcCodepageUTF8 in Options then<br></div><div dir="ltr"> Result:=''''+UTF16ToUTF8(WideChar(c))+''''<br></div><div dir="ltr"> else<br></div><div dir="ltr"> Result:='#'+IntToStr(c);<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function TCompWriterPas.GetStringLiteral(const s: string): string;<br></div><div dir="ltr"><br></div><div dir="ltr"> function IsSpecialChar(p: PChar): boolean;<br></div><div dir="ltr"> const<br></div><div dir="ltr"> SpecialChars = [#0..#31,#127,#255];<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> Result:=(p^ in SpecialChars) or (IsValidUTF8(p)=0);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr">var<br></div><div dir="ltr"> InLit: Boolean;<br></div><div dir="ltr"> p, StartP: PChar;<br></div><div dir="ltr"> c: Char;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> Result:='';<br></div><div dir="ltr"> if s='' then exit;<br></div><div dir="ltr"> InLit:=false;<br></div><div dir="ltr"> p:=PChar(s);<br></div><div dir="ltr"> repeat<br></div><div dir="ltr"> c:=p^;<br></div><div dir="ltr"> if (c=#0) and (p-PChar(s)=length(s)) then<br></div><div dir="ltr"> break<br></div><div dir="ltr"> else if IsSpecialChar(p) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if InLit then begin<br></div><div dir="ltr"> InLit:=false;<br></div><div dir="ltr"> Result:=Result+'''';<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> Result:=Result+'#'+IntToStr(ord(c));<br></div><div dir="ltr"> inc(p);<br></div><div dir="ltr"> end else begin<br></div><div dir="ltr"> if not InLit then begin<br></div><div dir="ltr"> InLit:=true;<br></div><div dir="ltr"> Result:=Result+'''';<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> if c='''' then begin<br></div><div dir="ltr"> Result:=Result+'''''';<br></div><div dir="ltr"> inc(p);<br></div><div dir="ltr"> end else begin<br></div><div dir="ltr"> StartP:=p;<br></div><div dir="ltr"> repeat<br></div><div dir="ltr"> inc(p,IsValidUTF8(p));<br></div><div dir="ltr"> c:=p^;<br></div><div dir="ltr"> until ((c=#0) and (p-PChar(s)=length(s))) or IsSpecialChar(p) or<br></div><div dir="ltr">(c='''');<br></div><div dir="ltr"> Result:=Result+copy(s,StartP-PChar(s)+1,p-StartP);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> until false;<br></div><div dir="ltr"> if InLit then<br></div><div dir="ltr"> Result:=Result+'''';<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function TCompWriterPas.GetWStringLiteral(p: PWideChar; Count: integer):<br></div><div dir="ltr">string;<br></div><div dir="ltr"><br></div><div dir="ltr"> function IsSpecialChar(w: PWideChar): boolean;<br></div><div dir="ltr"> const<br></div><div dir="ltr"> SpecialChars = [#0..#31,#127];<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if w^ in SpecialChars then exit(true);<br></div><div dir="ltr"> if cwpoSrcCodepageUTF8 in FOptions then begin<br></div><div dir="ltr"> Result:=IsValidUTF16(w)=0;<br></div><div dir="ltr"> end else begin<br></div><div dir="ltr"> Result:=w^>=#$7f;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"><br></div><div dir="ltr">var<br></div><div dir="ltr"> InLit: Boolean;<br></div><div dir="ltr"> c: WideChar;<br></div><div dir="ltr"> FirstP, StartP: PWideChar;<br></div><div dir="ltr"> AddLen: SizeUInt;<br></div><div dir="ltr"> s: string;<br></div><div dir="ltr"> OldLen: Integer;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> Result:='';<br></div><div dir="ltr"> if Count=0 then exit;<br></div><div dir="ltr"> FirstP:=p;<br></div><div dir="ltr"> InLit:=false;<br></div><div dir="ltr"> s:='';<br></div><div dir="ltr"> repeat<br></div><div dir="ltr"> c:=p^;<br></div><div dir="ltr"> if (c=#0) and (p-FirstP=Count) then<br></div><div dir="ltr"> break<br></div><div dir="ltr"> else if IsSpecialChar(p) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> if InLit then begin<br></div><div dir="ltr"> InLit:=false;<br></div><div dir="ltr"> Result:=Result+'''';<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> Result:=Result+'#'+Format('%.4d',[ord(c)]);<br></div><div dir="ltr"> inc(p);<br></div><div dir="ltr"> end else begin<br></div><div dir="ltr"> if not InLit then begin<br></div><div dir="ltr"> InLit:=true;<br></div><div dir="ltr"> Result:=Result+'''';<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> if c='''' then begin<br></div><div dir="ltr"> Result:=Result+'''''';<br></div><div dir="ltr"> inc(p);<br></div><div dir="ltr"> end else begin<br></div><div dir="ltr"> StartP:=p;<br></div><div dir="ltr"> repeat<br></div><div dir="ltr"> inc(p,IsValidUTF16(p));<br></div><div dir="ltr"> c:=p^;<br></div><div dir="ltr"> until ((c=#0) and (p-FirstP=Count)) or IsSpecialChar(p) or (c='''');<br></div><div dir="ltr"> AddLen:=p-StartP;<br></div><div dir="ltr"> if length(s)<AddLen*3 then SetLength(s,AddLen*3);<br></div><div dir="ltr"> if ConvertUTF16ToUTF8(@s[1],length(s),StartP,AddLen,<br></div><div dir="ltr"> [toInvalidCharError,toUnfinishedCharError],AddLen)=trNoError<br></div><div dir="ltr">then<br></div><div dir="ltr"> dec(AddLen); // omit #0<br></div><div dir="ltr"> OldLen:=length(Result);<br></div><div dir="ltr"> SetLength(Result,OldLen+AddLen);<br></div><div dir="ltr"> System.Move(s[1],Result[OldLen+1],AddLen);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> until false;<br></div><div dir="ltr"> if InLit then<br></div><div dir="ltr"> Result:=Result+'''';<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function TCompWriterPas.GetFloatLiteral(const e: Extended): string;<br></div><div dir="ltr">var<br></div><div dir="ltr"> s: String;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> s:='';<br></div><div dir="ltr"> str(e,s);<br></div><div dir="ltr"> Result:=ShortenFloat(s);<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function TCompWriterPas.GetCurrencyLiteral(const c: currency): string;<br></div><div dir="ltr">var<br></div><div dir="ltr"> i: int64 absolute c;<br></div><div dir="ltr">var<br></div><div dir="ltr"> s: String;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> if i mod 10000=0 then<br></div><div dir="ltr"> s:=IntToStr(i div 10000)<br></div><div dir="ltr"> else begin<br></div><div dir="ltr"> s:=IntToStr(i);<br></div><div dir="ltr"> while length(s)<4 do<br></div><div dir="ltr"> s:='0'+s;<br></div><div dir="ltr"> if length(s)=4 then<br></div><div dir="ltr"> s:='0.'+s<br></div><div dir="ltr"> else<br></div><div dir="ltr"> system.insert('.',s,length(s)-3);<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> Result:=s;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function TCompWriterPas.ShortenFloat(s: string): string;<br></div><div dir="ltr">var<br></div><div dir="ltr"> p, i: SizeInt;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> // remove unneeded leading 0 of exponent<br></div><div dir="ltr"> p:=Pos('E',s);<br></div><div dir="ltr"> if p<1 then exit;<br></div><div dir="ltr"> i:=p;<br></div><div dir="ltr"> if s[i+1]='+' then inc(i);<br></div><div dir="ltr"> while (i<length(s)) and (s[i+1]='0') do<br></div><div dir="ltr"> inc(i);<br></div><div dir="ltr"> if i>p then<br></div><div dir="ltr"> if i=length(s) then<br></div><div dir="ltr"> Delete(s,p,i-p+1) // delete whole exponent<br></div><div dir="ltr"> else<br></div><div dir="ltr"> Delete(s,p+1,i-p);<br></div><div dir="ltr"> // remove trailing 0 of base<br></div><div dir="ltr"> i:=p;<br></div><div dir="ltr"> while (i>2) and (s[i-1]='0') do<br></div><div dir="ltr"> dec(i);<br></div><div dir="ltr"> if not (s[i-1] in ['0'..'9']) then inc(i);<br></div><div dir="ltr"> if i<p then<br></div><div dir="ltr"> Delete(s,i,p-i);<br></div><div dir="ltr"> // remove leading space<br></div><div dir="ltr"> if s[1]=' ' then<br></div><div dir="ltr"> Delete(s,1,1);<br></div><div dir="ltr"> Result:=s;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function TCompWriterPas.GetEnumExpr(TypeInfo: PTypeInfo; Value: integer;<br></div><div dir="ltr"> AllowOutOfRange: boolean): string;<br></div><div dir="ltr">var<br></div><div dir="ltr"> PT: PTypeData;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> PT:=GetTypeData(TypeInfo);<br></div><div dir="ltr"> if (Value>=PT^.MinValue) and (Value<=PT^.MaxValue) then<br></div><div dir="ltr"> case TypeInfo^.Kind of<br></div><div dir="ltr"> tkBool: Result:=GetBoolLiteral(Value=ord(true));<br></div><div dir="ltr"> tkChar: Result:=GetCharLiteral(Value);<br></div><div dir="ltr"> tkEnumeration: Result:=GetEnumName(TypeInfo,Value);<br></div><div dir="ltr"> else Result:=IntToStr(Value);<br></div><div dir="ltr"> end<br></div><div dir="ltr"> else if AllowOutOfRange then<br></div><div dir="ltr"> Result:=TypeInfo^.Name+'('+IntToStr(Value)+')'<br></div><div dir="ltr"> else<br></div><div dir="ltr"> raise EWriteError.Create('enum '+IntToStr(Value)+' is out of range of<br></div><div dir="ltr">type "'+TypeInfo^.Name+'"');<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function TCompWriterPas.GetVersionStatement: string;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> Result:='// Format version '+IntToStr(CSPVersion);<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">constructor TCompWriterPas.Create(AStream: TStream);<br></div><div dir="ltr">var<br></div><div dir="ltr"> C: TAccessComp;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> FIndentStep:=2;<br></div><div dir="ltr"> FStream:=AStream;<br></div><div dir="ltr"> FLineEnding:=system.LineEnding;<br></div><div dir="ltr"> FAssignOp:=CSPDefaultAssignOp;<br></div><div dir="ltr"> FSignatureBegin:=CSPDefaultSignatureBegin;<br></div><div dir="ltr"> FSignatureEnd:=CSPDefaultSignatureEnd;<br></div><div dir="ltr"> FMaxColumn:=CSPDefaultMaxColumn;<br></div><div dir="ltr"> FExecCustomProc:=CSPDefaultExecCustomProc;<br></div><div dir="ltr"> FExecCustomProcUnit:=CSPDefaultExecCustomProcUnit;<br></div><div dir="ltr"> FNeededUnits:=TStringList.Create;<br></div><div dir="ltr"> FAccessClass:=CSPDefaultAccessClass;<br></div><div dir="ltr"> C:=TAccessComp.Create(nil);<br></div><div dir="ltr"> FDefaultDefineProperties:=TMethod(@C.DefineProperties).Code;<br></div><div dir="ltr"> C.Free;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">destructor TCompWriterPas.Destroy;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> FreeAndNil(FNeededUnits);<br></div><div dir="ltr"> inherited Destroy;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteComponentCreate(Component: TComponent);<br></div><div dir="ltr">var<br></div><div dir="ltr"> OldAncestor: TPersistent;<br></div><div dir="ltr"> OldRoot, OldRootAncestor: TComponent;<br></div><div dir="ltr"> HasAncestor: boolean;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> if (Component=LookupRoot) then exit;<br></div><div dir="ltr"> OldRoot:=FRoot;<br></div><div dir="ltr"> OldAncestor:=FAncestor;<br></div><div dir="ltr"> OldRootAncestor:=FRootAncestor;<br></div><div dir="ltr"> Try<br></div><div dir="ltr"> DetermineAncestor(Component);<br></div><div dir="ltr"> HasAncestor:=FAncestor is TComponent;<br></div><div dir="ltr"> if not CreatedByAncestor(Component) then<br></div><div dir="ltr"> <br></div><div dir="ltr">WriteAssign(Component.Name,Component.ClassName+'.Create('+GetComponentPath(Root)+')');<br></div><div dir="ltr"> if HasAncestor then begin<br></div><div dir="ltr"> if (csInline in Component.ComponentState)<br></div><div dir="ltr"> and not (csInline in TComponent(Ancestor).ComponentState) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> NeedAccessClass:=true;<br></div><div dir="ltr"> <br></div><div dir="ltr">WriteStatement(AccessClass+'(TComponent('+Component.Name+')).SetInline('+GetBoolLiteral(true)+');');<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> if (csAncestor in Component.ComponentState)<br></div><div dir="ltr"> and not (csAncestor in TComponent(Ancestor).ComponentState) then<br></div><div dir="ltr"> begin<br></div><div dir="ltr"> NeedAccessClass:=true;<br></div><div dir="ltr"> <br></div><div dir="ltr">WriteStatement(AccessClass+'(TComponent('+Component.Name+')).SetAncestor('+GetBoolLiteral(true)+');');<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> end;<br></div><div dir="ltr"> if not IgnoreChildren then<br></div><div dir="ltr"> WriteChildren(Component,cwpcsCreate);<br></div><div dir="ltr"> finally<br></div><div dir="ltr"> FAncestor:=OldAncestor;<br></div><div dir="ltr"> FRoot:=OldRoot;<br></div><div dir="ltr"> FRootAncestor:=OldRootAncestor;<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteComponent(Component: TComponent);<br></div><div dir="ltr">var<br></div><div dir="ltr"> OldAncestor : TPersistent;<br></div><div dir="ltr"> OldRoot, OldRootAncestor : TComponent;<br></div><div dir="ltr"> i: integer;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> OldRoot:=FRoot;<br></div><div dir="ltr"> OldAncestor:=FAncestor;<br></div><div dir="ltr"> OldRootAncestor:=FRootAncestor;<br></div><div dir="ltr"> Try<br></div><div dir="ltr"> // Component.ComponentState:=Component.FComponentState+[csWriting];<br></div><div dir="ltr"> DetermineAncestor(Component);<br></div><div dir="ltr"> WriteComponentData(Component);<br></div><div dir="ltr"> finally<br></div><div dir="ltr"> FAncestor:=OldAncestor;<br></div><div dir="ltr"> FRoot:=OldRoot;<br></div><div dir="ltr"> FRootAncestor:=OldRootAncestor;<br></div><div dir="ltr"> end;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteDescendant(ARoot: TComponent; AAncestor:<br></div><div dir="ltr">TComponent);<br></div><div dir="ltr">var<br></div><div dir="ltr"> i: integer;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> FRoot := ARoot;<br></div><div dir="ltr"> FAncestor := AAncestor;<br></div><div dir="ltr"> FRootAncestor := AAncestor;<br></div><div dir="ltr"> FLookupRoot := ARoot;<br></div><div dir="ltr"> FNeedAccessClass := false;<br></div><div dir="ltr"> if not (cwpoNoSignature in Options) then<br></div><div dir="ltr"> WriteStatement(SignatureBegin);<br></div><div dir="ltr"> WriteStatement(GetVersionStatement);<br></div><div dir="ltr"> if cwpoNoSelf in Options then<br></div><div dir="ltr"> WriteWithDo(ARoot.Name);<br></div><div dir="ltr"> WriteComponent(ARoot);<br></div><div dir="ltr"> if cwpoNoSelf in Options then<br></div><div dir="ltr"> WriteWithEnd;<br></div><div dir="ltr"> if not (cwpoNoSignature in Options) then<br></div><div dir="ltr"> WriteStatement(SignatureEnd);<br></div><div dir="ltr"><br></div><div dir="ltr"> UnIndent;<br></div><div dir="ltr"> WriteStatement('finally');<br></div><div dir="ltr"> { EndUpdate block }<br></div><div dir="ltr"> Indent;<br></div><div dir="ltr"> for i:=0 to ARoot.ComponentCount-1 do<br></div><div dir="ltr"> if ARoot.Components[i].ClassParent.InheritsFrom(TComponent) and not<br></div><div dir="ltr"> (ARoot.Components[i].ClassParent.ClassParent = TComponent) then<br></div><div dir="ltr"> WriteStatement(ARoot.Components[i].Name+'.EndUpdate;');<br></div><div dir="ltr"> UnIndent;<br></div><div dir="ltr"><br></div><div dir="ltr"> WriteStatement('end;');<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteIndent;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> Write(StringOfChar(' ',CurIndent));<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.Write(const s: string);<br></div><div dir="ltr">begin<br></div><div dir="ltr"> if s='' then exit;<br></div><div dir="ltr"> FStream.Write(s[1],length(s));<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteLn;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> Write(LineEnding);<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteStatement(const s: string);<br></div><div dir="ltr">begin<br></div><div dir="ltr"> WriteIndent;<br></div><div dir="ltr"> Write(s);<br></div><div dir="ltr"> WriteLn;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteAssign(const LHS, RHS: string);<br></div><div dir="ltr">begin<br></div><div dir="ltr"> WriteIndent;<br></div><div dir="ltr"> Write(LHS);<br></div><div dir="ltr"> Write(AssignOp);<br></div><div dir="ltr"> Write(RHS);<br></div><div dir="ltr"> Write(';');<br></div><div dir="ltr"> WriteLn;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteWithDo(const Expr: string);<br></div><div dir="ltr">begin<br></div><div dir="ltr"> if not (cwpoNoWithBlocks in Options) then<br></div><div dir="ltr"> WriteStatement('with '+Expr+' do begin');<br></div><div dir="ltr"> Indent;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.WriteWithEnd;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> Unindent;<br></div><div dir="ltr"> if not (cwpoNoWithBlocks in Options) then<br></div><div dir="ltr"> WriteStatement('end;');<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">function TCompWriterPas.CreatedByAncestor(Component: TComponent): boolean;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> Result:=(FAncestor is TComponent)<br></div><div dir="ltr"> and (TComponent(FAncestor).Owner = FRootAncestor)<br></div><div dir="ltr"> and (Component.Owner = Root)<br></div><div dir="ltr"> and SameText(Component.Name,TComponent(FAncestor).Name)<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.AddNeededUnit(const AnUnitName: string);<br></div><div dir="ltr">begin<br></div><div dir="ltr"> if FNeededUnits.IndexOf(AnUnitName)>=0 then exit;<br></div><div dir="ltr"> FNeededUnits.Add(AnUnitName);<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.Indent;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> CurIndent:=CurIndent+IndentStep;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">procedure TCompWriterPas.Unindent;<br></div><div dir="ltr">begin<br></div><div dir="ltr"> CurIndent:=CurIndent-IndentStep;<br></div><div dir="ltr">end;<br></div><div dir="ltr"><br></div><div dir="ltr">finalization<br></div><div dir="ltr"> DefinePropertiesEvents.Free;<br></div><div dir="ltr"><br></div><div dir="ltr">end.<br></div><div dir="ltr">---------------------<br></div><div dir="ltr"><br></div><div dir="ltr"><br></div><div dir="ltr"><br></div><div dir="ltr">--<br></div><div dir="ltr">Sent from: <a href="http://pas2js.38893.n8.nabble.com/" rel="nofollow" target="_blank">http://pas2js.38893.n8.nabble.com/</a><br></div><div dir="ltr"><br></div><div dir="ltr"><br></div><div dir="ltr">------------------------------<br></div><div dir="ltr"><br></div><div dir="ltr">Subject: Digest Footer<br></div><div dir="ltr"><br></div><div dir="ltr">_______________________________________________<br></div><div dir="ltr">Pas2js maillist - <a href="mailto:Pas2js@lists.freepascal.org" rel="nofollow" target="_blank">Pas2js@lists.freepascal.org</a><br></div><div dir="ltr"><a href="http://lists.freepascal.org/cgi-bin/mailman/listinfo/pas2js" rel="nofollow" target="_blank">http://lists.freepascal.org/cgi-bin/mailman/listinfo/pas2js</a><br></div><div dir="ltr"><br></div><div dir="ltr">------------------------------<br></div><div dir="ltr"><br></div><div dir="ltr">End of Pas2js Digest, Vol 11, Issue 22<br></div><div dir="ltr">**************************************<br></div></div>
</div>
</div></body></html>