Menu
▾
▴
[Instantobjects-cvscommit] SF.net SVN: instantobjects:[805] trunk/Source
|
From: <wp...@us...> - 2009-07-08 06:55:54
|
Revision: 805
http://instantobjects.svn.sourceforge.net/instantobjects/revision/?rev=805&view=rev
Author: wp2udk
Date: 2009-07-08 06:55:49 +0000 (Wed, 08 Jul 2009)
Log Message:
-----------
Import a model from an existing .res or .xml file and generate the equivalent Delphi source code. Only tested on Delphi 2006.
Modified Paths:
--------------
trunk/Source/Core/InstantCode.pas
trunk/Source/Design/D2006/DclIOCore.dpk
trunk/Source/Design/InstantModelExplorer.dfm
trunk/Source/Design/InstantModelExplorer.pas
trunk/Source/Design/iodesimages.res
Modified: trunk/Source/Core/InstantCode.pas
===================================================================
--- trunk/Source/Core/InstantCode.pas 2009-07-08 06:34:35 UTC (rev 804)
+++ trunk/Source/Core/InstantCode.pas 2009-07-08 06:55:49 UTC (rev 805)
@@ -962,6 +962,19 @@
property UnitName: string read GetUnitName write SetUnitName;
end;
+ TInstantCodeClassList = class(TList)
+ private
+ function GetItem(Index: Integer): TInstantCodeClass;
+ procedure SetItem(Index: Integer; const Value: TInstantCodeClass);
+ public
+ function Add(Item: TInstantCodeClass): Integer;
+ procedure Insert(Index: Integer; Item: TInstantCodeClass);
+
+ procedure SortByBaseClass;
+
+ property Items[Index: Integer]: TInstantCodeClass read GetItem write SetItem; default;
+ end;
+
TInstantCodeClassRef = class(TInstantCodeType)
protected
class function InternalAtInstance(Reader: TInstantCodeReader; out Name: string): Boolean; override;
@@ -5461,6 +5474,55 @@
(TInstantCodeMember(Sender).Visibility in Visibilities)
end;
+{ TInstantCodeClassList }
+
+function CompareCodeClasses(Item1, Item2: Pointer): Integer;
+var
+ CodeClass1, CodeClass2: TInstantCodeClass;
+begin
+ CodeClass1 := Item1;
+ CodeClass2 := Item2;
+
+ if (CodeClass1.BaseClass = nil) and (CodeClass2.BaseClass <> nil) then
+ Result := -1 else
+ if (CodeClass2.BaseClass = nil) and (CodeClass1.BaseClass <> nil) then
+ Result := 1 else
+ if CodeClass1.BaseClass = CodeClass2.BaseClass then
+ Result := 0 else
+ if CodeClass1.DerivesFrom(CodeClass2) then
+ Result := 1 else
+ if CodeClass2.DerivesFrom(CodeClass1) then
+ Result := -1 else
+ // CodeClass1.BaseClass <> CodeClass2.BaseClass
+ Result := CompareCodeClasses(CodeClass1.BaseClass, CodeClass2.BaseClass);
+end;
+
+function TInstantCodeClassList.Add(Item: TInstantCodeClass): Integer;
+begin
+ Result := inherited Add(Item);
+end;
+
+procedure TInstantCodeClassList.Insert(Index: Integer; Item: TInstantCodeClass);
+begin
+ inherited Insert(Index, Item);
+end;
+
+procedure TInstantCodeClassList.SortByBaseClass;
+begin
+ Sort(CompareCodeClasses);
+end;
+
+function TInstantCodeClassList.GetItem(Index: Integer): TInstantCodeClass;
+begin
+ Result := inherited Items[Index];
+end;
+
+procedure TInstantCodeClassList.SetItem(Index: Integer;
+ const Value: TInstantCodeClass);
+begin
+ inherited Items[Index] := Value;
+end;
+
{ TInstantCodeClassRef }
class function TInstantCodeClassRef.Identifier: string;
Modified: trunk/Source/Design/D2006/DclIOCore.dpk
===================================================================
--- trunk/Source/Design/D2006/DclIOCore.dpk 2009-07-08 06:34:35 UTC (rev 804)
+++ trunk/Source/Design/D2006/DclIOCore.dpk 2009-07-08 06:55:49 UTC (rev 805)
@@ -7,7 +7,6 @@
{$R '..\..\Core\InstantConnectionManager.dcr'}
{$R '..\..\Core\InstantPump.dcr'}
{$R '..\..\Core\InstantDBEvolution.dcr'}
-
{$ALIGN 8}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
@@ -58,7 +57,8 @@
InstantReg in '..\InstantReg.pas',
InstantUnitSelect in '..\InstantUnitSelect.pas' {InstantUnitSelectForm},
InstantAttributeEditor in '..\InstantAttributeEditor.pas' {InstantAttributeEditorForm},
- InstantAbout in '..\InstantAbout.pas' {InstantAboutForm};
+ InstantAbout in '..\InstantAbout.pas' {InstantAboutForm},
+ InstantModelImport in '..\InstantModelImport.pas' {InstantImportModelForm};
end.
Modified: trunk/Source/Design/InstantModelExplorer.dfm
===================================================================
--- trunk/Source/Design/InstantModelExplorer.dfm 2009-07-08 06:34:35 UTC (rev 804)
+++ trunk/Source/Design/InstantModelExplorer.dfm 2009-07-08 06:55:49 UTC (rev 805)
@@ -4,7 +4,6 @@
Width = 259
Height = 433
VertScrollBar.Range = 20
- AutoScroll = False
Caption = 'InstantObjects Model Explorer'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
@@ -23,7 +22,7 @@
Left = 0
Top = 27
Width = 251
- Height = 379
+ Height = 372
Align = alClient
BevelOuter = bvNone
TabOrder = 0
@@ -35,8 +34,6 @@
Height = 27
BorderWidth = 1
ButtonHeight = 23
- EdgeBorders = []
- Flat = True
Images = ActionImages
ParentShowHint = False
ShowHint = True
@@ -104,6 +101,9 @@
object N3: TMenuItem
Caption = '-'
end
+ object ImportModelItem: TMenuItem
+ Action = ImportModelAction
+ end
object ExportModelItem: TMenuItem
Action = ExportModelAction
end
@@ -189,6 +189,12 @@
Hint = 'Collapse All'
OnExecute = CollapseAllActionExecute
end
+ object ImportModelAction: TAction
+ Caption = '&Import Model...'
+ Hint = 'Import model'
+ ImageIndex = 11
+ OnExecute = ImportModelActionExecute
+ end
object ExportModelAction: TAction
Caption = '&Export Model...'
Hint = 'Export Model'
Modified: trunk/Source/Design/InstantModelExplorer.pas
===================================================================
--- trunk/Source/Design/InstantModelExplorer.pas 2009-07-08 06:34:35 UTC (rev 804)
+++ trunk/Source/Design/InstantModelExplorer.pas 2009-07-08 06:55:49 UTC (rev 805)
@@ -24,7 +24,8 @@
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
- * Carlo Barazzetta, Adrea Petrelli, Nando Dessena, Steven Mitchell
+ * Carlo Barazzetta, Adrea Petrelli, Nando Dessena, Steven Mitchell,
+ * Brian Andersen
*
* ***** END LICENSE BLOCK ***** *)
@@ -120,6 +121,8 @@
ViewRelationsAction: TAction;
ViewSourceAction: TAction;
ViewSourceItem: TMenuItem;
+ ImportModelItem: TMenuItem;
+ ImportModelAction: TAction;
procedure AboutActionExecute(Sender: TObject);
procedure BuildDatabaseActionExecute(Sender: TObject);
procedure CollapseAllActionExecute(Sender: TObject);
@@ -138,6 +141,7 @@
procedure ViewInheritanceActionExecute(Sender: TObject);
procedure ViewRelationsActionExecute(Sender: TObject);
procedure ViewSourceActionExecute(Sender: TObject);
+ procedure ImportModelActionExecute(Sender: TObject);
private
FError: TInstantModelError;
FModel: TInstantCodeModel;
@@ -195,7 +199,7 @@
InstantModelExpert,
{$ENDIF}
InstantDesignUtils, InstantPersistence, InstantDesignHook, InstantAbout,
- InstantImageUtils;
+ InstantImageUtils, InstantMetadata, InstantModelImport;
resourcestring
SDeleteClass = 'Delete Class ''%s''?';
@@ -381,6 +385,93 @@
SelectedNode.Expand(True);
end;
+procedure TInstantModelExplorerForm.ImportModelActionExecute(Sender: TObject);
+var
+ ClassIndex, AttributeIndex: Integer;
+ ImportModule: TInstantCodeModule;
+ ImportFileName: string;
+ ImportFileType: TInstantStreamFormat;
+ ImportModel: TInstantModel;
+ ImportClassMetadata: TInstantClassMetadata;
+ ImportBaseClassName: string;
+ ImportAttributeMetadata: TInstantAttributeMetadata;
+ NewClasses: TInstantCodeClassList;
+ NewClass: TInstantCodeClass;
+ NewAttribute: TInstantCodeAttribute;
+begin
+ with TInstantImportModelForm.Create(nil) do
+ try
+ if Execute(FModel) then
+ begin
+ ImportModule := SelectedModule;
+ ImportFileName := SelectedFileName;
+ ImportFileType := SelectedFileType;
+ end else
+ Exit;
+ finally
+ Free;
+ end;
+
+ ImportModel := TInstantModel.Create;
+ try
+ if ImportFileType = sfBinary then
+ ImportModel.LoadFromResFile(ImportFileName) else
+ ImportModel.LoadFromFile(ImportFileName);
+
+ FModelView.Items.BeginUpdate;
+ try
+ NewClasses := TInstantCodeClassList.Create;
+ try
+ for ClassIndex := 0 to ImportModel.ClassMetadatas.Count - 1 do
+ begin
+ ImportClassMetadata := ImportModel.ClassMetadatas[ClassIndex];
+
+ NewClass := ImportModule.InterfaceSection.AddClass;
+ ImportBaseClassName := ImportClassMetadata.ParentName;
+ if ImportBaseClassName = '' then
+ ImportBaseClassName := TInstantObject.ClassName;
+ NewClass.BaseClassName := ImportBaseClassName;
+ NewClass.Name := ImportClassMetadata.Name;
+ NewClass.Metadata.Assign(ImportClassMetadata);
+
+ for AttributeIndex := 0 to ImportClassMetadata.AttributeMetadatas.Count - 1 do
+ begin
+ ImportAttributeMetadata := ImportClassMetadata.AttributeMetadatas[AttributeIndex];
+
+ NewAttribute := NewClass.AddAttribute;
+ NewAttribute.IsIndexed := ImportAttributeMetadata.IsIndexed;
+ NewAttribute.IsRequired := ImportAttributeMetadata.IsRequired;
+ NewAttribute.IsDefault := ImportAttributeMetadata.IsDefault;
+ NewAttribute.AttributeType := ImportAttributeMetadata.AttributeType;
+ NewAttribute.AttributeTypeName := ImportAttributeMetadata.AttributeTypeName;
+ NewAttribute.Name := ImportAttributeMetadata.FieldName;
+ NewAttribute.StorageKind := ImportAttributeMetadata.StorageKind;
+ NewAttribute.StorageName := ImportAttributeMetadata.StorageName;
+ NewAttribute.ObjectClassName := ImportAttributeMetadata.ObjectClassName;
+ NewAttribute.Realize;
+ end;
+ NewClasses.Add(NewClass)
+ end;
+
+ // Classes needs to be sorted with base classes first or else the code
+ // generation might not be done correct.
+ NewClasses.SortByBaseClass;
+
+ for ClassIndex := 0 to NewClasses.Count - 1 do
+ ApplyClass(NewClasses[ClassIndex], ctNew, '');
+ finally
+ NewClasses.Free;
+ end;
+ finally
+ FModelView.Items.EndUpdate;
+ end;
+ finally
+ ImportModel.Free;
+ end;
+
+ Refresh;
+end;
+
procedure TInstantModelExplorerForm.ExportModelActionExecute(
Sender: TObject);
begin
@@ -590,6 +681,7 @@
SelectUnitsAction.Enabled := HasProject;
BuildDatabaseAction.Enabled := HasClasses;
NewClassAction.Enabled := HasModel;
+ ImportModelAction.Enabled := HasModel;
ExportModelAction.Enabled := HasModel;
EditClassAction.Enabled := AtClass;
ViewSourceAction.Enabled := AtClass;
Modified: trunk/Source/Design/iodesimages.res
===================================================================
(Binary files differ)
|
