added example how to stream components

git-svn-id: trunk@8810 -
2025-06-03 06:18:20 +02:00 · 2006-02-23 14:57:19 +00:00 · 2006-02-23 14:57:19 +00:00 · 509e8de76c
commit 509e8de76c
parent b0aa934e60
7 changed files with 468 additions and 0 deletions
--- a/.gitattributes
+++ b/.gitattributes
@ -810,6 +810,11 @@ examples/combobox.lpi svneol=native#text/plain
 examples/combobox.pp svneol=native#text/pascal
 examples/comdialogs.lpi svneol=native#text/plain
 examples/comdialogs.pp svneol=native#text/pascal
+examples/componentstreaming/componentstreaming.lpi svneol=native#text/plain
+examples/componentstreaming/componentstreaming.lpr svneol=native#text/plain
+examples/componentstreaming/mainunit.lfm svneol=native#text/plain
+examples/componentstreaming/mainunit.lrs svneol=native#text/plain
+examples/componentstreaming/mainunit.pas svneol=native#text/plain
 examples/dlgform.pp svneol=native#text/pascal
 examples/easter/about.lfm svneol=native#text/plain
 examples/easter/about.lrs svneol=native#text/pascal
--- a/examples/componentstreaming/componentstreaming.lpi
+++ b/examples/componentstreaming/componentstreaming.lpi
@ -0,0 +1,64 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <PathDelim Value="/"/>
+    <Version Value="5"/>
+    <General>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <IconPath Value="./"/>
+      <TargetFileExt Value=""/>
+    </General>
+    <LazDoc Paths=""/>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IgnoreBinaries Value="False"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="componentstreaming.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="ComponentStreaming"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="mainunit.pas"/>
+        <ComponentName Value="CompStreamDemoForm"/>
+        <IsPartOfProject Value="True"/>
+        <ResourceFilename Value="mainunit.lrs"/>
+        <UnitName Value="MainUnit"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="5"/>
+    <SearchPaths>
+      <SrcPath Value="$(LazarusDir)/lcl/;$(LazarusDir)/lcl/interfaces/$(LCLWidgetType)/"/>
+    </SearchPaths>
+    <CodeGeneration>
+      <Generate Value="Faster"/>
+    </CodeGeneration>
+    <Linking>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+    <Other>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+</CONFIG>
--- a/examples/componentstreaming/componentstreaming.lpr
+++ b/examples/componentstreaming/componentstreaming.lpr
@ -0,0 +1,18 @@
+program ComponentStreaming;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms
+  { add your units here }, MainUnit;
+
+begin
+  Application.Initialize;
+  Application.CreateForm(TCompStreamDemoForm, CompStreamDemoForm);
+  Application.Run;
+end.
+
--- a/examples/componentstreaming/mainunit.lfm
+++ b/examples/componentstreaming/mainunit.lfm
@ -0,0 +1,115 @@
+object CompStreamDemoForm: TCompStreamDemoForm
+  Caption = 'Streaming components example'
+  ClientHeight = 485
+  ClientWidth = 525
+  OnCreate = FormCreate
+  PixelsPerInch = 112
+  HorzScrollBar.Page = 524
+  VertScrollBar.Page = 484
+  Left = 292
+  Height = 485
+  Top = 168
+  Width = 525
+  object Note1Label: TLabel
+    Caption = 'This example demonstrates, how to stream a component to a stream in binary format ...'
+    Color = clNone
+    ParentColor = False
+    WordWrap = True
+    Left = 253
+    Height = 133
+    Top = 27
+    Width = 217
+  end
+  object Note2Label: TLabel
+    Caption = '... and how to reconstruct the component from a stream. This technique can be used to save components to disk or to transfer them via network. Of course this also works for your own classes as long as they are descendants of TComponent.'
+    Color = clNone
+    ParentColor = False
+    WordWrap = True
+    Left = 265
+    Height = 103
+    Top = 325
+    Width = 228
+  end
+  object SourceGroupBox: TGroupBox
+    Caption = 'Source'
+    ClientHeight = 73
+    ClientWidth = 191
+    TabOrder = 0
+    Left = 15
+    Height = 90
+    Top = 25
+    Width = 195
+    object AGroupBox: TGroupBox
+      Caption = 'AGroupBox'
+      ClientHeight = 26
+      ClientWidth = 124
+      TabOrder = 0
+      Left = 23
+      Height = 43
+      Top = 15
+      Width = 128
+    end
+  end
+  object DestinationGroupBox: TGroupBox
+    Anchors = [akLeft, akBottom]
+    Caption = 'Destination'
+    ClientHeight = 92
+    ClientWidth = 211
+    TabOrder = 1
+    Left = 30
+    Height = 109
+    Top = 360
+    Width = 215
+  end
+  object WriteToStreamButton: TButton
+    BorderSpacing.InnerBorder = 2
+    Caption = '1. Write AGroupBox to stream'
+    OnClick = WriteToStreamButtonClick
+    TabOrder = 2
+    Left = 23
+    Height = 25
+    Top = 130
+    Width = 197
+  end
+  object StreamGroupBox: TGroupBox
+    Anchors = [akTop, akLeft, akRight, akBottom]
+    Caption = 'Stream (special characters are shown as hexnumbers)'
+    ClientHeight = 115
+    ClientWidth = 492
+    TabOrder = 3
+    Left = 15
+    Height = 132
+    Top = 170
+    Width = 496
+    object StreamMemo: TMemo
+      Align = alClient
+      Lines.Strings = (
+        'First click on the button above, then on button below'
+      )
+      ReadOnly = True
+      TabOrder = 0
+      Height = 91
+      Width = 492
+    end
+    object StreamAsLFMCheckBox: TCheckBox
+      Align = alBottom
+      Caption = 'Show sream in LFM format (text)'
+      OnChange = StreamAsLFMCheckBoxChange
+      TabOrder = 1
+      Height = 24
+      Top = 91
+      Width = 492
+    end
+  end
+  object ReadStreamButton: TButton
+    Anchors = [akLeft, akBottom]
+    BorderSpacing.InnerBorder = 2
+    Caption = '2. Create component from stream'
+    OnClick = ReadStreamButtonClick
+    TabOrder = 4
+    Left = 25
+    Height = 24
+    Top = 316
+    Width = 215
+  end
+end
--- a/examples/componentstreaming/mainunit.lrs
+++ b/examples/componentstreaming/mainunit.lrs
@ -0,0 +1,41 @@
+{ This is an automatically generated lazarus resource file }
+
+LazarusResources.Add('TCompStreamDemoForm','FORMDATA',[
+  'TPF0'#19'TCompStreamDemoForm'#18'CompStreamDemoForm'#7'Caption'#6#28'Streami'
+  +'ng components example'#12'ClientHeight'#3#229#1#11'ClientWidth'#3#13#2#8'On'
+  +'Create'#7#10'FormCreate'#13'PixelsPerInch'#2'p'#18'HorzScrollBar.Page'#3#12
+  +#2#18'VertScrollBar.Page'#3#228#1#4'Left'#3'$'#1#6'Height'#3#229#1#3'Top'#3
+  +#168#0#5'Width'#3#13#2#0#6'TLabel'#10'Note1Label'#7'Caption'#6'UThis example'
+  +' demonstrates, how to stream a component to a stream in binary format ...'#5
+  +'Color'#7#6'clNone'#11'ParentColor'#8#8'WordWrap'#9#4'Left'#3#253#0#6'Height'
+  +#3#133#0#3'Top'#2#27#5'Width'#3#217#0#0#0#6'TLabel'#10'Note2Label'#7'Caption'
+  +#6#236'... and how to reconstruct the component from a stream. This techniqu'
+  +'e can be used to save components to disk or to transfer them via network. O'
+  +'f course this also works for your own classes as long as they are descendan'
+  +'ts of TComponent.'#5'Color'#7#6'clNone'#11'ParentColor'#8#8'WordWrap'#9#4'L'
+  +'eft'#3#9#1#6'Height'#2'g'#3'Top'#3'E'#1#5'Width'#3#228#0#0#0#9'TGroupBox'#14
+  +'SourceGroupBox'#7'Caption'#6#6'Source'#12'ClientHeight'#2'I'#11'ClientWidth'
+  +#3#191#0#8'TabOrder'#2#0#4'Left'#2#15#6'Height'#2'Z'#3'Top'#2#25#5'Width'#3
+  +#195#0#0#9'TGroupBox'#9'AGroupBox'#7'Caption'#6#9'AGroupBox'#12'ClientHeight'
+  +#2#26#11'ClientWidth'#2'|'#8'TabOrder'#2#0#4'Left'#2#23#6'Height'#2'+'#3'Top'
+  +#2#15#5'Width'#3#128#0#0#0#0#9'TGroupBox'#19'DestinationGroupBox'#7'Anchors'
+  +#11#6'akLeft'#8'akBottom'#0#7'Caption'#6#11'Destination'#12'ClientHeight'#2
+  +'\'#11'ClientWidth'#3#211#0#8'TabOrder'#2#1#4'Left'#2#30#6'Height'#2'm'#3'To'
+  +'p'#3'h'#1#5'Width'#3#215#0#0#0#7'TButton'#19'WriteToStreamButton'#25'Border'
+  +'Spacing.InnerBorder'#2#2#7'Caption'#6#28'1. Write AGroupBox to stream'#7'On'
+  +'Click'#7#24'WriteToStreamButtonClick'#8'TabOrder'#2#2#4'Left'#2#23#6'Height'
+  +#2#25#3'Top'#3#130#0#5'Width'#3#197#0#0#0#9'TGroupBox'#14'StreamGroupBox'#7
+  +'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#8'akBottom'#0#7'Caption'#6'3Strea'
+  +'m (special characters are shown as hexnumbers)'#12'ClientHeight'#2's'#11'Cl'
+  +'ientWidth'#3#236#1#8'TabOrder'#2#3#4'Left'#2#15#6'Height'#3#132#0#3'Top'#3
+  +#170#0#5'Width'#3#240#1#0#5'TMemo'#10'StreamMemo'#5'Align'#7#8'alClient'#13
+  +'Lines.Strings'#1#6'5First click on the button above, then on button below'#0
+  +#8'ReadOnly'#9#8'TabOrder'#2#0#6'Height'#2'['#5'Width'#3#236#1#0#0#9'TCheckB'
+  +'ox'#19'StreamAsLFMCheckBox'#5'Align'#7#8'alBottom'#7'Caption'#6#31'Show sre'
+  +'am in LFM format (text)'#8'OnChange'#7#25'StreamAsLFMCheckBoxChange'#8'TabO'
+  +'rder'#2#1#6'Height'#2#24#3'Top'#2'['#5'Width'#3#236#1#0#0#0#7'TButton'#16'R'
+  +'eadStreamButton'#7'Anchors'#11#6'akLeft'#8'akBottom'#0#25'BorderSpacing.Inn'
+  +'erBorder'#2#2#7'Caption'#6#31'2. Create component from stream'#7'OnClick'#7
+  +#21'ReadStreamButtonClick'#8'TabOrder'#2#4#4'Left'#2#25#6'Height'#2#24#3'Top'
+  +#3'<'#1#5'Width'#3#215#0#0#0#0
+]);
--- a/examples/componentstreaming/mainunit.pas
+++ b/examples/componentstreaming/mainunit.pas
@ -0,0 +1,176 @@
+unit MainUnit;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, LCLProc, LResources, Forms, Controls, Graphics,
+  Dialogs, StdCtrls, Buttons;
+
+type
+
+  { TCompStreamDemoForm }
+
+  TCompStreamDemoForm = class(TForm)
+    AGroupBox: TGroupBox;
+    StreamAsLFMCheckBox: TCheckBox;
+    Note2Label: TLabel;
+    Note1Label: TLabel;
+    ReadStreamButton: TButton;
+    StreamMemo: TMemo;
+    StreamGroupBox: TGroupBox;
+    WriteToStreamButton: TButton;
+    SourceGroupBox: TGroupBox;
+    DestinationGroupBox: TGroupBox;
+    procedure FormCreate(Sender: TObject);
+    procedure ReadStreamButtonClick(Sender: TObject);
+    procedure StreamAsLFMCheckBoxChange(Sender: TObject);
+    procedure WriteToStreamButtonClick(Sender: TObject);
+  public
+    StreamAsString: string;
+    procedure ShowStreamInMemo;
+    procedure SaveStreamAsString(AStream: TStream);
+    procedure ReadStreamFromString(AStream: TStream);
+    function ReadStringFromStream(AStream: TStream): string;
+    procedure ClearDestinationGroupBox;
+    procedure OnFindClass(Reader: TReader; const AClassName: string;
+                          var ComponentClass: TComponentClass);
+  end;
+
+var
+  CompStreamDemoForm: TCompStreamDemoForm;
+
+implementation
+
+{ TCompStreamDemoForm }
+
+procedure TCompStreamDemoForm.WriteToStreamButtonClick(Sender: TObject);
+var
+  AStream: TMemoryStream;
+begin
+  AStream:=TMemoryStream.Create;
+  try
+    WriteComponentAsBinaryToStream(AStream,AGroupBox);
+    SaveStreamAsString(AStream);
+  finally
+    AStream.Free;
+  end;
+end;
+
+procedure TCompStreamDemoForm.ReadStreamButtonClick(Sender: TObject);
+var
+  NewComponent: TComponent;
+  AStream: TMemoryStream;
+begin
+  ClearDestinationGroupBox;
+
+  AStream:=TMemoryStream.Create;
+  try
+    ReadStreamFromString(AStream);
+    NewComponent:=nil;
+    ReadComponentFromBinaryStream(AStream,NewComponent,
+                                  @OnFindClass,DestinationGroupBox);
+    if NewComponent is TControl then
+      TControl(NewComponent).Parent:=DestinationGroupBox;
+  finally
+    AStream.Free;
+  end;
+end;
+
+procedure TCompStreamDemoForm.FormCreate(Sender: TObject);
+var
+  ACheckBox: TCheckBox;
+begin
+  // create a checkbox with Owner = AGroupBox
+  // because TWriter writes all components owned by AGroupBox
+  ACheckBox:=TCheckBox.Create(AGroupBox);
+  with ACheckBox do begin
+    Name:='ACheckBox';
+    Parent:=AGroupBox;
+  end;
+end;
+
+procedure TCompStreamDemoForm.StreamAsLFMCheckBoxChange(Sender: TObject);
+begin
+  ShowStreamInMemo;
+end;
+
+procedure TCompStreamDemoForm.ShowStreamInMemo;
+var
+  LRSStream: TMemoryStream;
+  LFMStream: TMemoryStream;
+begin
+  if StreamAsLFMCheckBox.Checked then begin
+    // convert the stream to LFM
+    LRSStream:=TMemoryStream.Create;
+    LFMStream:=TMemoryStream.Create;
+    try
+      ReadStreamFromString(LRSStream);
+      LRSObjectBinaryToText(LRSStream,LFMStream);
+      StreamMemo.Lines.Text:=ReadStringFromStream(LFMStream);
+    finally
+      LRSStream.Free;
+      LFMStream.Free;
+    end;
+  end else begin
+    // the stream is in binary format and contains characters, that can not be
+    // shown in the memo. Convert all special characters to hexnumbers.
+    StreamMemo.Lines.Text:=DbgStr(StreamAsString);
+  end;
+end;
+
+procedure TCompStreamDemoForm.SaveStreamAsString(AStream: TStream);
+begin
+  StreamAsString:=ReadStringFromStream(AStream);
+  ShowStreamInMemo;
+end;
+
+procedure TCompStreamDemoForm.ReadStreamFromString(AStream: TStream);
+begin
+  AStream.Size:=0;
+  if StreamAsString<>'' then
+    AStream.Write(StreamAsString[1],length(StreamAsString));
+  AStream.Position:=0;
+end;
+
+function TCompStreamDemoForm.ReadStringFromStream(AStream: TStream): string;
+begin
+  AStream.Position:=0;
+  SetLength(Result,AStream.Size);
+  if Result<>'' then
+    AStream.Read(Result[1],length(Result));
+end;
+
+procedure TCompStreamDemoForm.ClearDestinationGroupBox;
+{ free all components owned by DestinationGroupBox
+  Do not confuse 'Owner' and 'Parent';
+  The 'Owner' of a TComponent is responsible for freeing the component.
+  All components owned by a component can be found in the 'Components'
+  property.
+  The 'Parent' of a TControl is the visible container. For example
+  DestinationGroupBox has as Parent the form.
+  All controls with the same parent are gathered in Parent.Controls.
+  
+  In this simple example the created component has as Owner and Parent the
+  DestinationGroupBox.
+}
+begin
+  while DestinationGroupBox.ComponentCount>0 do
+    DestinationGroupBox.Components[0].Free;
+end;
+
+procedure TCompStreamDemoForm.OnFindClass(Reader: TReader;
+  const AClassName: string; var ComponentClass: TComponentClass);
+begin
+  if CompareText(AClassName,'TGroupBox')=0 then
+    ComponentClass:=TGroupBox
+  else if CompareText(AClassName,'TCheckBox')=0 then
+    ComponentClass:=TCheckBox;
+end;
+
+initialization
+  {$I mainunit.lrs}
+
+end.
+
--- a/lcl/lresources.pp
+++ b/lcl/lresources.pp
@ -231,6 +231,10 @@ function CreateLRSWriter(s: TStream; var DestroyDriver: boolean): TWriter;

 function GetClassNameFromLRSStream(s: TStream; out IsInherited: Boolean): shortstring;
 procedure WriteComponentAsBinaryToStream(AStream: TStream; AComponent: TComponent);
+procedure ReadComponentFromBinaryStream(AStream: TStream;
+                           var RootComponent: TComponent;
+                           OnFindComponentClass: TFindComponentClassEvent;
+                           TheOwner: TComponent = nil);

 procedure BinaryToLazarusResourceCode(BinStream, ResStream: TStream;
  const ResourceName, ResourceType: String);
@ -369,6 +373,51 @@ begin
  end;
 end;

+procedure ReadComponentFromBinaryStream(AStream: TStream;
+  var RootComponent: TComponent;
+  OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent);
+var
+  DestroyDriver: Boolean;
+  Reader: TReader;
+  IsInherited: Boolean;
+  AClassName: String;
+  AClass: TComponentClass;
+begin
+  // get root class
+  AClassName:=GetClassNameFromLRSStream(AStream,IsInherited);
+  AClass:=nil;
+  OnFindComponentClass(nil,AClassName,AClass);
+  if AClass=nil then
+    raise EClassNotFound.CreateFmt('Class "%s" not found', [AClassName]);
+
+  if RootComponent=nil then begin
+    // create root component
+    // first create the new instance and set the variable ...
+    RootComponent:=AClass.NewInstance as TComponent;
+    // then call the constructor
+    RootComponent.Create(TheOwner);
+  end else begin
+    // there is a root component, check if class is compatible
+    if not RootComponent.InheritsFrom(AClass) then begin
+      raise EComponentError.CreateFmt('Cannot assign a %s to a %s.',
+                                      [AClassName,RootComponent.ClassName]);
+    end;
+  end;
+
+  // read the root component
+  DestroyDriver:=false;
+  Reader:=nil;
+  try
+    Reader:=CreateLRSReader(AStream,DestroyDriver);
+    Reader.OnFindComponentClass:=OnFindComponentClass;
+    Reader.ReadRootComponent(RootComponent);
+  finally
+    if DestroyDriver then
+      Reader.Driver.Free;
+    Reader.Free;
+  end;
+end;
+
 procedure BinaryToLazarusResourceCode(BinStream,ResStream:TStream;
  const ResourceName, ResourceType: String);
 { example ResStream: