Updated OI from Mattias

Shane

git-svn-id: trunk@63 -

designer/designer.pp

@@ -43,9 +43,10 @@ type
     FControlSelection : TControlSelection;
     function GetIsControl: Boolean;
     procedure SetIsControl(Value: Boolean);
+    FSource : TStringList;
   protected
     ControlSelection : TControlSelection;
-
+    Function NewModuleSource(nmUnitName, nmForm, nmAncestor: String) : Boolean;
   public
     constructor Create(customform : TCustomform);
     destructor Destroy; override;
@@ -64,23 +65,61 @@ type
 
  implementation
 
+uses
+  Sysutils, Typinfo;
 var
 GridPoints : TGridPoint;
 
+
 constructor TDesigner.Create(CustomForm : TCustomForm);
+var
+    PT : PTypeData;
+    PI : PTypeInfo;
+    nmForm,nmAncestor : String;
+    I : Integer;
 begin
-inherited Create;
+  inherited Create;
 
 
-FCustomForm := CustomForm;
+  FCustomForm := CustomForm;
-//The controlselection should NOT be owned by the form.  When it is it shows up in the OI
+  FSource := TStringList.Create;
-ControlSelection := TControlSelection.Create(CustomForm);
+  //create the code for the unit
+  PI := CustomForm.ClassInfo;
+
+  nmForm := PI^.Name;
+  Delete(nmForm,1,1);
+
+  PT:=GetTypeData(PI);
+  //DumpMem(PByte(PI));
+  If PT^.ParentInfo <> Nil then
+     Begin
+       nmAncestor := PT^.ParentInfo^.Name;
+       delete(nmAncestor,1,1);
+     end
+     else
+       nmAncestor := 'Object';
+
+  NewModuleSource('Unit1',nmForm,nmAncestor);
+
+  //The controlselection should NOT be owned by the form.  When it is it shows up in the OI
+  ControlSelection := TControlSelection.Create(CustomForm);
+
+try
+  Writeln('**********************************************');
+  for I := 1 to FSource.Count do
+  writeln(FSource.Strings[i-1]);
+  Writeln('**********************************************');
+except
+  Application.Messagebox('error','error',0);
+end;
 end;
 
 destructor TDesigner.Destroy;
 Begin
-Inherited;
 ControlSelection.free;
+FSource.Free;
+
+Inherited;
 end;
 
 procedure TDesigner.CreateNew(FileName : string);
@@ -88,22 +127,56 @@ begin
 
 end;
 
+function TDesigner.IsDesignMsg(Sender: TControl; var Message: TLMessage): Boolean;
+Begin
+
+end;
+
 procedure TDesigner.LoadFile(FileName: string);
 begin
 
 end;
 
-
-function TDesigner.IsDesignMsg(Sender: TControl; var Message: TLMessage): Boolean;
-Begin
-
-end;
-
 procedure TDesigner.Modified;
 Begin
 
 end;
 
+Function TDesigner.NewModuleSource(nmUnitName, nmForm, nmAncestor: String): Boolean;
+Var
+I : Integer;
+Begin
+FSource.Clear;
+Result := True;
+with FSource do
+     try
+       Add(Format('unit %s;', [nmUnitname]));
+       Add('');
+       Add('interface');
+       Add('');
+       Add('uses Classes, Graphics, Controls, Forms, Dialogs;');
+       Add('');
+       Add('type');
+       Add(Format('     T%s = class(T%s)', [nmForm,nmAncestor]));
+       Add('     private');
+       Add('     { private declarations}');
+       Add('     public');
+       Add('     { public declarations }');
+       Add('     end;');
+       Add('');
+       Add('var');
+       Add(Format('     %s: T%0:s;', [nmForm]));
+       Add('');
+       Add('implementation');
+       Add('');
+       Add('end.');
+     except
+       Result := False;
+     end;
+end;
+
+
+
 procedure TDesigner.Notification(AComponent: TComponent; Operation: TOperation);
 Begin
  if Operation = opInsert then

designer/propedits.pp

@@ -4,7 +4,7 @@ unit propedits;
 
   Abstract:
     This units defines the property editors used by the object inspector.
-    A Property Editor is the the interface between a row of the object inspector
+    A Property Editor is the interface between a row of the object inspector
     and a property in the RTTI.
     For more information see the big comment part below.
 
@@ -793,7 +793,7 @@ const
     nil                    // tkQWord
     );
 
-// XXX ToDo: There is a big in the typinfo.pp. Thus this workaround -------
+// XXX ToDo: There are bugs in the typinfo.pp. Thus this workaround -------
 
 Procedure SetIndexValues (P: PPRopInfo; Var Index,IValue : Longint);
 begin
@@ -804,44 +804,141 @@ begin
     IValue:=0;
 end;
 
+function CallIntegerFunc(s: Pointer; Address: Pointer; Index, IValue: LongInt): Int64; assembler;
+asm
+  movl S,%esi
+  movl Address,%edi
+  // ? Indexed function
+  movl Index,%eax
+  testl %eax,%eax
+  je .LINoPush
+  movl IValue,%eax
+  pushl %eax
+.LINoPush:
+  push %esi
+  call %edi
+  // now the result is in EDX:EAX
+end;
+
+Procedure CallSStringFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint;
+                        Var Res: Shortstring);assembler;
+asm
+  movl S,%esi
+  movl Address,%edi
+  // ? Indexed function
+  movl Index,%eax
+  testl %eax,%eax
+  jnz .LSSNoPush
+  movl IValue,%eax
+  pushl %eax
+  // the result is stored in an invisible parameter
+  pushl Res
+.LSSNoPush:
+  push %esi
+  call %edi
+end;
+
+Function GetAStrProp(Instance : TObject;PropInfo : PPropInfo):Pointer;
+{
+Dirty trick based on fact that AnsiString is just a pointer,
+hence can be treated like an integer type.
+}
+var
+  value : Pointer;
+  Index,Ivalue : Longint;
+begin
+  SetIndexValues(PropInfo,Index,IValue);
+  case (PropInfo^.PropProcs) and 3 of
+    ptfield:
+      Value:=Pointer(PLongint(Pointer(Instance)+Longint(PropInfo^.GetProc))^);
+    ptstatic:
+      Value:=Pointer(LongInt(
+        CallIntegerFunc(Instance,PropInfo^.GetProc,Index,IValue)));
+    ptvirtual:
+      Value:=Pointer(LongInt(CallIntegerFunc(Instance,
+        PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,
+        Index,IValue)));
+  end;
+  GetAStrProp:=Value;
+end;
+
+Function GetSStrProp(Instance : TObject;PropInfo : PPropInfo):ShortString;
+var
+  value : ShortString;
+  Index,IValue : Longint;
+begin
+  SetIndexValues(PropInfo,Index,IValue);
+  case (PropInfo^.PropProcs) and 3 of
+    ptfield:
+      Value:=PShortString(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
+    ptstatic:
+     CallSStringFunc(Instance,PropInfo^.GetProc,Index,IValue,Value);
+    ptvirtual:
+     CallSSTringFunc(Instance,
+       PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,
+       Index,Ivalue,Value);
+  end;
+  GetSStrProp:=Value;
+end;
+
+function GetStrProp(Instance : TObject;PropInfo : PPropInfo) : Ansistring;
+var s:Ansistring;
+begin
+  Case Propinfo^.PropType^.Kind of
+    tkSString : Result:=GetSStrProp(Instance,PropInfo);
+    tkAString :
+      { Dirty trick which is necessary to increase the reference
+       counter of Result... }
+      begin
+        Pointer(Result):=GetAStrProp(Instance,Propinfo);
+        s:=Result;
+        Pointer(s):=nil;
+      end;
+  else
+    Result:='';
+  end;
+end;
+
+//------------------------------------------------------------------------------
+
 function CallIntegerProc(s : Pointer;Address : Pointer;Value : Integer;
 Index,IValue : Longint) : Integer;  assembler;
 asm
-   movl S,%esi
+  movl S,%esi
-   movl Address,%edi
+  movl Address,%edi
-   // Push value to set
+  // Push value to set
-   movl Value,%eax
+  movl Value,%eax
-   pushl %eax
+  pushl %eax
-   // ? Indexed procedure
+  // ? Indexed procedure
-   movl Index,%eax
+  movl Index,%eax
-   testl %eax,%eax
+  testl %eax,%eax
-   je .LIPNoPush
+  je .LIPNoPush
-   movl IValue,%eax
+  movl IValue,%eax
-   pushl %eax
+  pushl %eax
 .LIPNoPush:
-   pushl %esi
+  pushl %esi
-   call %edi
+  call %edi
 end;
 
 procedure CallSStringProc(s : Pointer;Address : Pointer;
   const Value : ShortString; Index,IVAlue : Longint);  assembler;
 asm
-   movl S,%esi
+  movl S,%esi
-   movl Address,%edi
+  movl Address,%edi
-   // Push value to set
+  // Push value to set
-   movl Value,%eax
+  movl Value,%eax
-   pushl %eax
+  pushl %eax
-   // ? Indexed procedure
+  // ? Indexed procedure
-   movl Index,%eax
+  movl Index,%eax
-   testl %eax,%eax
+  testl %eax,%eax
-   // MG: here was a bug (jnz)
+  // MG: here was a bug (jnz)
-   je .LSSPNoPush
+  je .LSSPNoPush
-   movl IValue,%eax
+  movl IValue,%eax
-   pushl %eax
+  pushl %eax
 .LSSPNoPush:
-   // MG: and here was a bug too (push)
+  // MG: and here was a bug too (push)
-   pushl %esi
+  pushl %esi
-   call %edi
+  call %edi
 end;
 
 procedure SetAStrProp(Instance : TObject;PropInfo : PPropInfo;
@@ -2199,7 +2296,7 @@ end;
 
 function TComponentPropertyEditor.GetEditLimit: Integer;
 begin
-  Result := 127;
+  Result := MaxIdentLength;
 end;
 
 function TComponentPropertyEditor.GetValue: string;

designer/test_unit.pp

@@ -10,12 +10,60 @@ interface
 
 uses
   Classes, StdCtrls, Forms, Buttons, Menus, ComCtrls, SysUtils, ExtCtrls,
-  ObjectInspector, PropEdits, Graphics;
+  ObjectInspector, PropEdits, Graphics, TypInfo;
 
 type
   TMyEnum = (MyEnum1,MyEnum2,MyEnum3);
   TMySet = set of TMyEnum;
 
+  TMySubComponent = class(TComponent)
+  public
+    FMyInteger:integer;
+  published
+    property MyInteger:integer read FMyInteger write FMyInteger;
+  end;
+
+  TMyComponent = class(TComponent)
+  public
+    FMyInteger:integer;
+    FMyCardinal:Cardinal;
+    FMyInt64:int64;
+    FMyEnum:TMyEnum;
+    FMySet:TMySet;
+    FMyFloat:extended;
+    FMyAnsiString:AnsiString;
+    FMyShortString:ShortString;
+    FMyBool:boolean;
+    FMySubComponent:TMySubComponent;
+    FMyGraphicsObject:TGraphicsObject;
+    FMyBrush:TBrush;
+    FMyPen:TPen;
+    FMyFont:TFont;
+    FMyEvent:TNotifyEvent;
+    procedure DoSomething(Sender:TObject);
+    procedure SetMyAnsiString(const NewValue:AnsiString);
+    procedure SetMyShortString(const NewValue:ShortString);
+    constructor Create(AOwner:TComponent);  override;
+    destructor Destroy;  override;
+  published
+    MySubComponent2:TMySubComponent;
+    property MyInteger:integer read FMyInteger write FMyInteger;
+    property MyCardinal:cardinal read FMyCardinal write FMyCardinal;
+//    property MyInt64:int64 read FMyInt64 write FMyInt64;
+    property MyEnum:TMyEnum read FMyEnum write FMyEnum;
+    property MySet:TMySet read FMySet write FMySet;
+    property MyFloat:Extended read FMyFloat write FMyFloat;
+    property MyAnsiString:AnsiString read FMyAnsiString write SetMyAnsiString;
+    property MyShortString:ShortString read FMyShortString write SetMyShortString;
+    property MyBool:Boolean read FMyBool write FMyBool;
+    property MySubComponent:TMySubComponent read FMySubComponent write FMySubComponent;
+//    property MyGraphicsObject:TGraphicsObject read FMyGraphicsObject write FMyGraphicsObject;
+//    property MyBrush:TBrush read FMyBrush write FMyBrush;
+//    property MyPen:TPen read FMyPen write FMyPen;
+//    property MyFont:TFont read FMyFont write FMyFont;
+//    property MyEvent:TNotifyEvent read FMyEvent write FMyEvent;
+  end;
+
 	TForm1 = class(TFORM)
 	public
 	  Label1 : TLabel;
@@ -35,7 +83,8 @@ type
 	  itmFile: TMenuItem;
     ComboBox1 : TComboBox;
     ComboBox2 : TComboBox;
-    Memo1     : TMemo;
+    Memo1 : TMemo;
+    WriteLFMButton:TButton;
     constructor Create(AOwner: TComponent); override;	
     procedure LoadMainMenu;
 	  procedure FormKill(Sender : TObject);
@@ -52,17 +101,19 @@ type
 	  procedure OIRefreshButtonCLick(Sender : TObject);
 	  procedure ComboOnChange (Sender:TObject);
 	  procedure ComboOnClick (Sender:TObject);
+    procedure WriteLFMButtonClick(Sender:TObject);
   public
     FMyInteger:integer;
     FMyCardinal:Cardinal;
     FMyEnum:TMyEnum;
     FMySet:TMySet;
-    FMyFont:TFont;
     FMyAnsiString:AnsiString;
     FMyShortString:ShortString;
     FMyBool:boolean;
     FMyBrush:TBrush;
     FMyPen:TPen;
+    FMyFont:TFont;
+    FMyComponent:TMyComponent;
     procedure SetMyAnsiString(const NewValue:AnsiString);
     procedure SetMyShortString(const NewValue:ShortString);
   published
@@ -70,20 +121,635 @@ type
     property MyCardinal:cardinal read FMyCardinal write FMyCardinal;
     property MyEnum:TMyEnum read FMyEnum write FMyEnum;
     property MySet:TMySet read FMySet write FMySet;
-    property MyFont:TFont read FMyFont write FMyFont;
     property MyAnsiString:AnsiString read FMyAnsiString write SetMyAnsiString;
     property MyShortString:ShortString read FMyShortString write SetMyShortString;
     property MyBool:Boolean read FMyBool write FMyBool;
     property MyBrush:TBrush read FMyBrush write FMyBrush;
     property MyPen:TPen read FMyPen write FMyPen;
+    property MyFont:TFont read FMyFont write FMyFont;
+    property MyComponent:TMyComponent read FMyComponent write FMyComponent;
 	end;
 
+  TMatBinaryObjectWriter = class(TAbstractObjectWriter)
+  private
+    FStream: TStream;
+    FBuffer: Pointer;
+    FBufSize: Integer;
+    FBufPos: Integer;
+    FSignatureWritten: Boolean;
+    procedure FlushBuffer;
+    procedure Write(const Buffer; Count: Longint);
+    procedure WriteValue(Value: TValueType);
+    procedure WriteStr(const Value: AnsiString);
+  public
+    constructor Create(Stream: TStream; BufSize: Integer);
+    destructor Destroy; override;
+
+    procedure BeginCollection; override;
+    procedure BeginComponent(Component: TComponent; Flags: TFilerFlags;
+      ChildPos: Integer); override;
+    procedure BeginList; override;
+    procedure EndList; override;
+    procedure BeginProperty(const PropName: AnsiString); override;
+    procedure EndProperty; override;
+
+    procedure WriteBinary(const Buffer; Count: LongInt); override;
+    procedure WriteBoolean(Value: Boolean); override;
+    procedure WriteFloat(const Value: Extended); override;
+    procedure WriteSingle(const Value: Single); override;
+    {!!!: procedure WriteCurrency(const Value: Currency);  override;}
+    procedure WriteDate(const Value: TDateTime); override;
+    procedure WriteIdent(const Ident: Ansistring); override;
+    procedure WriteInteger(Value: Int64); override;
+    procedure WriteMethodName(const Name: AnsiString); override;
+    procedure WriteSet(Value: LongInt; SetType: Pointer); override;
+    procedure WriteString(const Value: AnsiString); override;
+  end;
+
+
 var
   Form1 : TForm1;
   OI: TObjectInspector;
 
 implementation
 
+
+
+//==============================================================================
+
+
+procedure ObjectBinaryToText(Input, Output: TStream);
+
+  procedure OutStr(s: String);
+  begin
+    writeln('OutStr '''+s+''' NewTotalLen='+IntToStr(OutPut.Size));
+    if Length(s) > 0 then
+      Output.Write(s[1], Length(s));
+  end;
+
+  procedure OutLn(s: String);
+  begin
+    OutStr(s + #10);
+  end;
+
+  procedure OutString(s: String);
+  var
+    res, NewStr: String;
+    i: Integer;
+    InString, NewInString: Boolean;
+  begin
+    writeln('OutString '''+s+'''');
+    res := '';
+    InString := False;
+    for i := 1 to Length(s) do begin
+      NewInString := InString;
+      case s[i] of
+        #0..#31: begin
+            if InString then
+              NewInString := False;
+            NewStr := '#' + IntToStr(Ord(s[i]));
+          end;
+        '''':
+            if InString then NewStr := ''''''
+            else NewStr := '''''''';
+        else begin
+          if not InString then
+            NewInString := True;
+          NewStr := s[i];
+        end;
+      end;
+      if NewInString <> InString then begin
+        NewStr := '''' + NewStr;
+        InString := NewInString;
+      end;
+      res := res + NewStr;
+    end;
+    if InString then res := res + '''';
+    OutStr(res);
+  end;
+
+  function ReadInt(ValueType: TValueType): LongInt;
+  begin
+    writeln('ReadInt(ValueType)');
+    case ValueType of
+      vaInt8: Result := ShortInt(Input.ReadByte);
+      vaInt16: Result := SmallInt(Input.ReadWord);
+      vaInt32: Result := LongInt(Input.ReadDWord);
+    end;
+  end;
+
+  function ReadInt: LongInt;
+  begin
+    writeln('ReadInt');
+    Result := ReadInt(TValueType(Input.ReadByte));
+  end;
+
+  function ReadSStr: String;
+  var
+    len: Byte;
+  begin
+    writeln('ReadStr');
+    len := Input.ReadByte;
+    SetLength(Result, len);
+    Input.Read(Result[1], len);
+  end;
+
+  procedure ReadPropList(indent: String);
+
+    procedure ProcessValue(ValueType: TValueType; Indent: String);
+
+      procedure Stop(s: String);
+      begin
+        WriteLn(s);
+        Halt;
+      end;
+
+      procedure ProcessBinary;
+      var
+        ToDo, DoNow, i: LongInt;
+        lbuf: array[0..31] of Byte;
+        s: String;
+      begin
+        ToDo := Input.ReadDWord;
+        OutLn('{');
+        while ToDo > 0 do begin
+          DoNow := ToDo;
+          if DoNow > 32 then DoNow := 32;
+          Dec(ToDo, DoNow);
+          s := Indent + '  ';
+          Input.Read(lbuf, DoNow);
+          for i := 0 to DoNow - 1 do
+            s := s + IntToHex(lbuf[i], 2);
+          OutLn(s);
+        end;
+        OutLn(indent + '}');
+      end;
+
+    var
+      s: String;
+      len: LongInt;
+      IsFirst: Boolean;
+      ext: Extended;
+
+    begin
+    writeln('ProcessValue Indent='''+Indent+'''');
+      OutStr('(' + IntToStr(Ord(Valuetype)) + ') ');
+      case ValueType of
+        vaList: begin
+            OutStr('(');
+            IsFirst := True;
+            while True do begin
+              ValueType := TValueType(Input.ReadByte);
+              if ValueType = vaNull then break;
+              if IsFirst then begin
+                OutLn('');
+                IsFirst := False;
+              end;
+              OutStr(Indent + '  ');
+              ProcessValue(ValueType, Indent + '  ');
+            end;
+            OutLn(Indent + ')');
+          end;
+        vaInt8: OutLn(IntToStr(ShortInt(Input.ReadByte)));
+        vaInt16: OutLn( IntToStr(SmallInt(Input.ReadWord)));
+        vaInt32: OutLn(IntToStr(LongInt(Input.ReadDWord)));
+        vaExtended: begin
+            Input.Read(ext, SizeOf(ext));
+            OutLn(FloatToStr(ext));
+          end;
+        vaString: begin
+            OutString(ReadSStr);
+            OutLn('');
+          end;
+        vaIdent: OutLn(ReadSStr);
+        vaFalse: OutLn('False');
+        vaTrue: OutLn('True');
+        vaBinary: ProcessBinary;
+        vaSet: begin
+            OutStr('[');
+            IsFirst := True;
+            while True do begin
+              s := ReadSStr;
+              if Length(s) = 0 then break;
+              if not IsFirst then OutStr(', ');
+              IsFirst := False;
+              OutStr(s);
+            end;
+            OutLn(']');
+          end;
+        vaLString: Stop('!!LString!!');
+        vaNil: OutLn('nil'); // Stop('nil');
+        vaCollection: begin
+            OutStr('<');
+            while Input.ReadByte <> 0 do begin
+              OutLn(Indent);
+              Input.Seek(-1, soFromCurrent);
+              OutStr(indent + '  item');
+              ValueType := TValueType(Input.ReadByte);
+              if ValueType <> vaList then
+                OutStr('[' + IntToStr(ReadInt(ValueType)) + ']');
+              OutLn('');
+              ReadPropList(indent + '    ');
+              OutStr(indent + '  end');
+            end;
+            OutLn('>');
+          end;
+        {vaSingle: begin OutLn('!!Single!!'); exit end;
+        vaCurrency: begin OutLn('!!Currency!!'); exit end;
+        vaDate: begin OutLn('!!Date!!'); exit end;
+        vaWString: begin OutLn('!!WString!!'); exit end;}
+        else
+          Stop(IntToStr(Ord(ValueType)));
+      end;
+    end;
+
+  begin
+    writeln('ReadPropList');
+    while Input.ReadByte <> 0 do begin
+      Input.Seek(-1, soFromCurrent);
+      OutStr(indent + ReadSStr + ' = ');
+      ProcessValue(TValueType(Input.ReadByte), Indent);
+    end;
+  end;
+
+  procedure ReadObject(indent: String);
+  var
+    b: Byte;
+    ObjClassName, ObjName: String;
+    ChildPos: LongInt;
+  begin
+    writeln('ReadObject');
+    // Check for FilerFlags
+    b := Input.ReadByte;
+    if (b and $f0) = $f0 then begin
+      if (b and 2) <> 0 then ChildPos := ReadInt;
+    end else begin
+      b := 0;
+      Input.Seek(-1, soFromCurrent);
+    end;
+
+    ObjClassName := ReadSStr;
+    ObjName := ReadSStr;
+
+    OutStr(Indent);
+    if (b and 1) <> 0 then OutStr('inherited')
+    else OutStr('object');
+    OutStr(' ');
+    if ObjName <> '' then
+      OutStr(ObjName + ': ');
+    OutStr(ObjClassName);
+    if (b and 2) <> 0 then OutStr('[' + IntToStr(ChildPos) + ']');
+    OutLn('');
+
+    ReadPropList(indent + '  ');
+
+    while Input.ReadByte <> 0 do begin
+      Input.Seek(-1, soFromCurrent);
+      ReadObject(indent + '  ');
+    end;
+    OutLn(indent + 'end');
+  end;
+
+type
+  PLongWord = ^LongWord;
+const
+  signature: PChar = 'TPF0';
+begin
+  if Input.ReadDWord <> PLongWord(Pointer(signature))^ then
+    raise EReadError.Create('Illegal stream image' {###SInvalidImage});
+  ReadObject('');
+end;
+
+//==============================================================================
+
+
+{ TMyComponent }
+
+constructor TMyComponent.Create(AOwner:TComponent);
+begin
+  inherited Create(AOwner);
+  Name:='MyComponent';
+  FMyInteger:=-1234;
+  FMyCardinal:=5678;
+  FMySet:=[MyEnum1];
+  FMyEnum:=MyEnum2;
+  FMyFloat:=3.2;
+  FMyBool:=true;
+  FMyAnsiString:='Ansi';
+  FMyShortString:='Short';
+  FMySubComponent:=TMySubComponent.Create(Self);
+  with FMySubComponent do begin
+    MyInteger:=789;
+  end;
+  FMyGraphicsObject:=nil;
+  FMyFont:=TFont.Create;
+  FMyBrush:=TBrush.Create;
+  FMyPen:=TPen.Create;
+  FMyEvent:=@DoSomething;
+
+  MySubComponent2:=TMySubComponent.Create(Self);
+  with MySubComponent2 do begin
+    MyInteger:=1928;
+  end;
+end;
+
+destructor TMyComponent.Destroy;
+begin
+  FMyPen.Free;
+  FMyBrush.Free;
+  FMyFont.Free;
+  FMySubComponent.Free;
+  inherited Destroy;
+end;
+
+procedure TMyComponent.SetMyAnsiString(const NewValue:AnsiString);
+begin
+  FMyAnsiString:=NewValue;
+end;
+
+procedure TMyComponent.SetMyShortString(const NewValue:ShortString);
+begin
+  FMyShortString:=NewValue;
+end;
+
+procedure TMyComponent.DoSomething(Sender:TObject);
+begin
+  //
+end;
+
+//==============================================================================
+
+
+
+{ TMatBinaryObjectWriter }
+
+constructor TMatBinaryObjectWriter.Create(Stream: TStream; BufSize: Integer);
+begin
+writeln('MBOW: Create');
+  inherited Create;
+  FStream := Stream;
+  FBufSize := BufSize;
+  GetMem(FBuffer, BufSize);
+end;
+
+destructor TMatBinaryObjectWriter.Destroy;
+begin
+writeln('MBOW: Destroy');
+  // Flush all data which hasn't been written yet
+  FlushBuffer;
+
+  if Assigned(FBuffer) then
+    FreeMem(FBuffer, FBufSize);
+
+  inherited Destroy;
+end;
+
+procedure TMatBinaryObjectWriter.BeginCollection;
+begin
+writeln('MBOW: BeginCollection');
+  WriteValue(vaCollection);
+end;
+
+procedure TMatBinaryObjectWriter.BeginComponent(Component: TComponent;
+  Flags: TFilerFlags; ChildPos: Integer);
+var
+  Prefix: Byte;
+begin
+writeln('MBOW: BeginComponent');
+  if not FSignatureWritten then
+  begin
+    Write(FilerSignature, SizeOf(FilerSignature));
+    FSignatureWritten := True;
+  end;
+
+  { Only write the flags if they are needed! }
+  if Flags <> [] then
+  begin
+    Prefix := Integer(Flags) or $f0;
+    Write(Prefix, 1);
+    if ffChildPos in Flags then
+      WriteInteger(ChildPos);
+  end;
+
+  WriteStr(Component.ClassName);
+  WriteStr(Component.Name);
+writeln('MBOW: BeginComponent end');
+end;
+
+procedure TMatBinaryObjectWriter.BeginList;
+begin
+writeln('MBOW: BeginList');
+  WriteValue(vaList);
+end;
+
+procedure TMatBinaryObjectWriter.EndList;
+begin
+writeln('MBOW: EndList');
+  WriteValue(vaNull);
+end;
+
+procedure TMatBinaryObjectWriter.BeginProperty(const PropName: AnsiString);
+begin
+writeln('MBOW: BeginProperty '+PropName);
+  WriteStr(PropName);
+end;
+
+procedure TMatBinaryObjectWriter.EndProperty;
+begin
+writeln('MBOW: EndProperty');
+end;
+
+procedure TMatBinaryObjectWriter.WriteBinary(const Buffer; Count: LongInt);
+begin
+writeln('MBOW: WriteBinary');
+  WriteValue(vaBinary);
+  Write(Count, 4);
+  Write(Buffer, Count);
+end;
+
+procedure TMatBinaryObjectWriter.WriteBoolean(Value: Boolean);
+begin
+writeln('MBOW: WriteBoolean');
+  if Value then
+    WriteValue(vaTrue)
+  else
+    WriteValue(vaFalse);
+end;
+
+procedure TMatBinaryObjectWriter.WriteFloat(const Value: Extended);
+begin
+writeln('MBOW: WriteFloat');
+  WriteValue(vaExtended);
+  Write(Value, SizeOf(Value));
+end;
+
+procedure TMatBinaryObjectWriter.WriteSingle(const Value: Single);
+begin
+writeln('MBOW: WriteSingle');
+  WriteValue(vaSingle);
+  Write(Value, SizeOf(Value));
+end;
+
+{!!!: procedure TMatBinaryObjectWriter.WriteCurrency(const Value: Currency);
+begin
+  WriteValue(vaCurrency);
+  Write(Value, SizeOf(Value));
+end;}
+
+procedure TMatBinaryObjectWriter.WriteDate(const Value: TDateTime);
+begin
+writeln('MBOW: WriteDate');
+  WriteValue(vaDate);
+  Write(Value, SizeOf(Value));
+end;
+
+procedure TMatBinaryObjectWriter.WriteIdent(const Ident: Ansistring);
+begin
+writeln('MBOW: WriteIdent '+Ident);
+  { Check if Ident is a special identifier before trying to just write
+    Ident directly }
+  if UpperCase(Ident) = 'NIL' then
+    WriteValue(vaNil)
+  else if UpperCase(Ident) = 'FALSE' then
+    WriteValue(vaFalse)
+  else if UpperCase(Ident) = 'TRUE' then
+    WriteValue(vaTrue)
+  else if UpperCase(Ident) = 'NULL' then
+    WriteValue(vaNull) else
+  begin
+    WriteValue(vaIdent);
+    WriteStr(Ident);
+  end;
+end;
+
+procedure TMatBinaryObjectWriter.WriteInteger(Value: Int64);
+begin
+writeln('MBOW: WriteInteger '+IntToStr(Value));
+  { Use the smallest possible integer type for the given value: }
+  if (Value >= -128) and (Value <= 127) then
+  begin
+    WriteValue(vaInt8);
+    Write(Value, 1);
+  end else if (Value >= -32768) and (Value <= 32767) then
+  begin
+    WriteValue(vaInt16);
+    Write(Value, 2);
+  end else if (Value >= -$80000000) and (Value <= $7fffffff) then
+  begin
+    WriteValue(vaInt32);
+    Write(Value, 4);
+  end else
+  begin
+    WriteValue(vaInt64);
+    Write(Value, 8);
+  end;
+end;
+
+procedure TMatBinaryObjectWriter.WriteMethodName(const Name: AnsiString);
+begin
+writeln('MBOW: WriteMethodName '+Name);
+  if Length(Name) > 0 then
+  begin
+    WriteValue(vaIdent);
+    WriteStr(Name);
+  end else
+    WriteValue(vaNil);
+end;
+
+procedure TMatBinaryObjectWriter.WriteSet(Value: LongInt; SetType: Pointer);
+var
+  i: Integer;
+  Mask: LongInt;
+begin
+writeln('MBOW: WriteSet');
+  WriteValue(vaSet);
+  Mask := 1;
+  for i := 0 to 31 do
+  begin
+    if (Value and Mask) <> 0 then
+      WriteStr(GetEnumName(PTypeInfo(SetType), i));
+    Mask := Mask shl 1;
+  end;
+  WriteStr('');
+end;
+
+procedure TMatBinaryObjectWriter.WriteString(const Value: AnsiString);
+var
+  i: Integer;
+begin
+writeln('MBOW: WriteString '''+Value+'''');
+  i := Length(Value);
+  if i <= 255 then
+  begin
+    WriteValue(vaString);
+    Write(i, 1);
+  end else
+  begin
+    WriteValue(vaLString);
+    Write(i, 4);
+  end;
+  if i > 0 then
+    Write(Value[1], i);
+end;
+
+{!!!: procedure TMatBinaryObjectWriter.WriteWideString(const Value: WideString);
+var
+  i: Integer;
+begin
+  WriteValue(vaWString);
+  i := Length(Value);
+  Write(i, 4);
+  Write(Value[1], i * 2);
+end;}
+
+procedure TMatBinaryObjectWriter.FlushBuffer;
+begin
+writeln('MBOW: FlushBuffer');
+  FStream.WriteBuffer(FBuffer^, FBufPos);
+  FBufPos := 0;
+end;
+
+procedure TMatBinaryObjectWriter.Write(const Buffer; Count: LongInt);
+var
+  CopyNow: LongInt;
+begin
+writeln('MBOW: Write (Count='+IntToStr(Count)+')');
+  while Count > 0 do begin
+    CopyNow := Count;
+    if CopyNow > FBufSize - FBufPos then
+      CopyNow := FBufSize - FBufPos;
+    Move(Buffer, PChar(FBuffer)[FBufPos], CopyNow);
+    Dec(Count, CopyNow);
+    Inc(FBufPos, CopyNow);
+    if FBufPos = FBufSize then
+      FlushBuffer;
+  end;
+end;
+
+procedure TMatBinaryObjectWriter.WriteValue(Value: TValueType);
+begin
+writeln('MBOW: WriteValue');
+  Write(Value, 1);
+end;
+
+procedure TMatBinaryObjectWriter.WriteStr(const Value: AnsiString);
+var
+  i: Integer;
+begin
+writeln('MBOW: WriteStr '''+Value+'''');
+  i := Length(Value);
+  if i > 255 then
+    i := 255;
+  Write(i, 1);
+  if i > 0 then
+    Write(Value[1], i);
+end;
+
+
+//==============================================================================
+
+{ TForm1 }
+
 procedure TForm1.SetMyAnsiString(const NewValue:AnsiString);
 begin
   FMyAnsiString:=NewValue;
@@ -102,12 +768,17 @@ begin
   FMyFont:=TFont.Create;
   FMyBrush:=TBrush.Create;
   FMyPen:=TPen.Create;
+  FMyComponent:=TMyComponent.Create(nil);
+  with FMyComponent do begin
+    Name:='FMyComponent';
+  end;
 
   Name:='Form1';
   Caption := 'Test Form';
   OI:=nil;
   OnShow:=@FormShow;
   LoadMainMenu;
+  ActiveControl:=AddItemButton;
   Left:=250;
   Top:=50;
   if OI=nil then begin
@@ -121,12 +792,46 @@ end;
 
 procedure TForm1.FormKill(Sender : TObject);
 Begin
+  FMyComponent.Free;
   FMyBrush.Free;
   FMyPen.Free;
   FMyFont.Free;
-  Application.terminate;
+  Application.Terminate;
 End;
 
+procedure TForm1.WriteLFMButtonClick(Sender:TObject);
+var BinStream:TMemoryStream;
+  Driver: TAbstractObjectWriter;
+  Writer:TWriter;
+  TxtStream:TFileStream;
+  s:string;
+begin
+  BinStream:=TMemoryStream.Create;
+  try
+    Driver:=TMatBinaryObjectWriter.Create(BinStream,4096);
+    try
+      Writer:=TWriter.Create(Driver);
+      try
+        Writer.WriteDescendent(Self,nil);
+      finally
+        Writer.Free;
+      end;
+    finally
+      Driver.Free;
+    end;
+    TxtStream:=TFileStream.Create(Name+'.lfm',fmCreate);
+    try
+      BinStream.Position:=0;
+      ObjectBinaryToText(BinStream,TxtStream);
+    finally
+      TxtStream.Free;
+    end;
+  finally
+    BinStream.Free;
+  end;
+writeln('Object written.');
+end;
+
 procedure TForm1.FormShow(Sender: TObject);
 begin
 end;
@@ -178,7 +883,7 @@ Begin
       begin
          if assigned (Memo1)
             then Memo1.Lines.Add (ComboBox1.Items[i]);
-	 inc (i); 
+	       inc (i);
       end;
    end;
 End;
@@ -229,7 +934,7 @@ begin
    with OIResizeButton do begin
      Name:='OIResizeButton';
      Parent:=Self;
-     SetBounds(200,10,100,40);
+     SetBounds(200,10,100,30);
      Caption:='Resize OI';
      OnClick:=@OIResizeButtonClick;
      Show;
@@ -239,12 +944,22 @@ begin
    with OIRefreshButton do begin
      Name:='OIRefreshButton';
      Parent:=Self;
-     SetBounds(200,60,100,40);
+     SetBounds(200,50,100,30);
      Caption:='Refresh OI';
      OnClick:=@OIRefreshButtonClick;
      Show;
    end;
 
+   WriteLFMButton:=TButton.Create(Self);
+   with WriteLFMButton do begin
+     Name:='WriteLFMButton';
+     Parent:=Self;
+     SetBounds(200,90,100,30);
+     Caption:='Write LFM file';
+     OnClick:=@WriteLFMButtonClick;
+     Show;
+   end;
+
    { Create 2 buttons inside the groupbox }
    EditToComboButton := TButton.Create(Self);
    EditToComboButton.Name:='EditToComboButton';

lcl/interfaces/win32/win32int.pp

@@ -28,7 +28,7 @@ interface
 {$endif}
  
 uses Windows, Strings, sysutils, lmessages, Classes, Controls, dialogs, vclGlobals, forms,
-     extctrls;
+     extctrls,InterfaceBase;
  
 const
    csAlignment = 1;