313 lines
11 KiB
ObjectPascal
313 lines
11 KiB
ObjectPascal
{*******************************************************************}
|
|
{ }
|
|
{ ExpressWeb Framework by Developer Express }
|
|
{ Pascal script importers factory }
|
|
{ }
|
|
{ Copyright (c) 2000-2009 Developer Express Inc. }
|
|
{ ALL RIGHTS RESERVED }
|
|
{ }
|
|
{ The entire contents of this file is protected by U.S. and }
|
|
{ International Copyright Laws. Unauthorized reproduction, }
|
|
{ reverse-engineering, and distribution of all or any portion of }
|
|
{ the code contained in this file is strictly prohibited and may }
|
|
{ result in severe civil and criminal penalties and will be }
|
|
{ prosecuted to the maximum extent possible under the law. }
|
|
{ }
|
|
{ RESTRICTIONS }
|
|
{ }
|
|
{ THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES }
|
|
{ (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE }
|
|
{ SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS }
|
|
{ LICENSED TO DISTRIBUTE THE EXPRESSWEB FRAMEWORK AND ALL }
|
|
{ ACCOMPANYING VCL CLASSES AS PART OF AN EXECUTABLE WEB }
|
|
{ APPLICATION ONLY. }
|
|
{ }
|
|
{ THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED }
|
|
{ FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE }
|
|
{ COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE }
|
|
{ AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT }
|
|
{ AND PERMISSION FROM DEVELOPER EXPRESS INC. }
|
|
{ }
|
|
{ CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON }
|
|
{ ADDITIONAL RESTRICTIONS. }
|
|
{ }
|
|
{*******************************************************************}
|
|
unit cxWebPasImpFactory;
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, Contnrs,
|
|
ifps3, ifpscomp, ifpiclass, ifpiclassruntime;
|
|
|
|
type
|
|
TClassEnumProc = procedure(AClass: TClass; AObject: TObject);
|
|
|
|
TcxPascalScriptImporter = class
|
|
protected
|
|
class procedure DeclareTypes(ACompiler: TIFPSPascalCompiler); virtual;
|
|
class procedure DeclareClassMembers(ACTClass: TIFPSCompileTimeClass); virtual;
|
|
class procedure RegisterClassMembers(ARTClass: TIFPSRuntimeClass); virtual;
|
|
class procedure EnumDependentClasses(Proc: TClassEnumProc; AObject: TObject); virtual;
|
|
public
|
|
class procedure CompileTimeRegistration(AImporter: TIFPSCompileTimeClassesImporter);
|
|
class procedure RunTimeRegistration(AImporter: TIFPSRuntimeClassImporter);
|
|
class function ObjectClass: TClass; virtual;
|
|
end;
|
|
|
|
TcxPascalScriptImporterClass = class of TcxPascalScriptImporter;
|
|
|
|
TcxPascalScriptImporterFactory = class
|
|
private
|
|
FClassList: TStringList;
|
|
protected
|
|
constructor CreateInstance(ADummy: Boolean = True);
|
|
class function AccessInstance(Request: Integer): TcxPascalScriptImporterFactory;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
class function Instance: TcxPascalScriptImporterFactory;
|
|
class procedure ReleaseInstance;
|
|
|
|
function GetImporterClass(AObjectClass: TClass): TcxPascalScriptImporterClass; overload;
|
|
function GetImporterClass(AObject: TObject): TcxPascalScriptImporterClass; overload;
|
|
procedure GetImporterClassList(const AUnitName: string; AClassList: TClassList);
|
|
procedure RegisterImporter(AImporterClass: TcxPascalScriptImporterClass; const AVirtualUnit: string);
|
|
procedure UnregisterImporter(AImporterClass: TcxPascalScriptImporterClass);
|
|
end;
|
|
|
|
function cxPasScriptImpFactory: TcxPascalScriptImporterFactory;
|
|
function cxCTRegisterClass(AImporter: TIFPSCompileTimeClassesImporter;
|
|
AClass: TClass): TIFPSCompileTimeClass;
|
|
function cxRTRegisterClass(AImporter: TIFPSRuntimeClassImporter;
|
|
AClass: TClass): TIFPSRuntimeClass;
|
|
|
|
const
|
|
scxStringType = 'string'; //do not localize
|
|
scxStringsType = 'TStrings'; //do not localize
|
|
scxIntegerType = 'Integer'; //do not localize
|
|
scxByteType = 'Byte'; //do not localize
|
|
scxBooleanType = 'Boolean'; //do not localize
|
|
scxDateTimeType = 'TDateTime'; //do not localize
|
|
scxVariantType = 'Variant'; //do not localize
|
|
scxComponentType = 'TComponent'; //do not localize
|
|
|
|
implementation
|
|
|
|
uses
|
|
cxWebScript;
|
|
|
|
function cxCTRegisterClass(AImporter: TIFPSCompileTimeClassesImporter;
|
|
AClass: TClass): TIFPSCompileTimeClass;
|
|
var
|
|
ParentClass: TClass;
|
|
ParentCTClass: TIFPSCompileTimeClass;
|
|
begin
|
|
Result := nil;
|
|
if AImporter.FindClass(AClass.ClassName) <> nil then Exit;
|
|
ParentClass := AClass.ClassParent;
|
|
ParentCTClass := nil;
|
|
while (ParentCTClass = nil) and (ParentClass <> nil) do
|
|
begin
|
|
ParentCTClass := AImporter.FindClass(ParentClass.ClassName);
|
|
ParentClass := ParentClass.ClassParent;
|
|
end;
|
|
Result := AImporter.Add(ParentCTClass, AClass);
|
|
end;
|
|
|
|
function cxRTRegisterClass(AImporter: TIFPSRuntimeClassImporter;
|
|
AClass: TClass): TIFPSRuntimeClass;
|
|
begin
|
|
if AImporter.FindClass(UpperCase(AClass.ClassName)) = nil then
|
|
Result := AImporter.Add(AClass)
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
{ TcxPascalScriptImporter }
|
|
|
|
procedure DeclareAndRegisterDependentClass(AClass: TClass; AObject: TObject);
|
|
var
|
|
ScriptImp: TcxPascalScriptImporterClass;
|
|
begin
|
|
ScriptImp := cxPasScriptImpFactory.GetImporterClass(AClass);
|
|
if ScriptImp <> nil then
|
|
begin
|
|
if AObject is TIFPSCompileTimeClassesImporter then
|
|
ScriptImp.CompileTimeRegistration(AObject as TIFPSCompileTimeClassesImporter);
|
|
if AObject is TIFPSRuntimeClassImporter then
|
|
ScriptImp.RunTimeRegistration(AObject as TIFPSRuntimeClassImporter);
|
|
end;
|
|
end;
|
|
|
|
class procedure TcxPascalScriptImporter.CompileTimeRegistration(
|
|
AImporter: TIFPSCompileTimeClassesImporter);
|
|
var
|
|
CTClass: TIFPSCompileTimeClass;
|
|
begin
|
|
if ClassParent.InheritsFrom(TcxPascalScriptImporter) then
|
|
TcxPascalScriptImporterClass(ClassParent).CompileTimeRegistration(AImporter);
|
|
CTClass := cxCTRegisterClass(AImporter, ObjectClass);
|
|
if CTClass <> nil then
|
|
begin
|
|
DeclareTypes(AImporter.SE);
|
|
EnumDependentClasses(DeclareAndRegisterDependentClass, AImporter);
|
|
CTClass.RegisterPublishedProperties;
|
|
DeclareClassMembers(CTClass);
|
|
end;
|
|
end;
|
|
|
|
class procedure TcxPascalScriptImporter.RunTimeRegistration(
|
|
AImporter: TIFPSRuntimeClassImporter);
|
|
var
|
|
RTClass: TIFPSRuntimeClass;
|
|
begin
|
|
RTClass := cxRTRegisterClass(AImporter, ObjectClass);
|
|
if RTClass <> nil then
|
|
begin
|
|
EnumDependentClasses(DeclareAndRegisterDependentClass, AImporter);
|
|
RegisterClassMembers(RTClass);
|
|
end;
|
|
end;
|
|
|
|
class function TcxPascalScriptImporter.ObjectClass: TClass;
|
|
begin
|
|
Result := TObject;
|
|
end;
|
|
|
|
class procedure TcxPascalScriptImporter.DeclareClassMembers(
|
|
ACTClass: TIFPSCompileTimeClass);
|
|
begin
|
|
end;
|
|
|
|
class procedure TcxPascalScriptImporter.DeclareTypes(
|
|
ACompiler: TIFPSPascalCompiler);
|
|
begin
|
|
end;
|
|
|
|
class procedure TcxPascalScriptImporter.RegisterClassMembers(
|
|
ARTClass: TIFPSRuntimeClass);
|
|
begin
|
|
end;
|
|
|
|
class procedure TcxPascalScriptImporter.EnumDependentClasses(
|
|
Proc: TClassEnumProc; AObject: TObject);
|
|
begin
|
|
end;
|
|
|
|
{ TcxScriptDispClassFactory }
|
|
|
|
var
|
|
FPasScriptImpFactoryInstance: TcxPascalScriptImporterFactory = nil;
|
|
|
|
function cxPasScriptImpFactory: TcxPascalScriptImporterFactory;
|
|
begin
|
|
Result := TcxPascalScriptImporterFactory.Instance;
|
|
end;
|
|
|
|
constructor TcxPascalScriptImporterFactory.Create;
|
|
begin
|
|
inherited Create;
|
|
raise Exception.CreateFmt('Access class %s through Instance only', [ClassName]);
|
|
end;
|
|
|
|
destructor TcxPascalScriptImporterFactory.Destroy;
|
|
begin
|
|
FClassList.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
constructor TcxPascalScriptImporterFactory.CreateInstance(ADummy: Boolean = True);
|
|
begin
|
|
FClassList := TStringList.Create;
|
|
end;
|
|
|
|
class function TcxPascalScriptImporterFactory.AccessInstance(Request: Integer): TcxPascalScriptImporterFactory;
|
|
begin
|
|
case Request of
|
|
0 : ;
|
|
1 : if not Assigned(FPasScriptImpFactoryInstance) then FPasScriptImpFactoryInstance := CreateInstance;
|
|
2 : FreeAndNil(FPasScriptImpFactoryInstance);
|
|
else
|
|
raise Exception.CreateFmt('Illegal request %d in AccessInstance',
|
|
[Request]);
|
|
end;
|
|
Result := FPasScriptImpFactoryInstance;
|
|
end;
|
|
|
|
class function TcxPascalScriptImporterFactory.Instance: TcxPascalScriptImporterFactory;
|
|
begin
|
|
Result := AccessInstance(1);
|
|
end;
|
|
|
|
class procedure TcxPascalScriptImporterFactory.ReleaseInstance;
|
|
begin
|
|
AccessInstance(2);
|
|
end;
|
|
|
|
procedure TcxPascalScriptImporterFactory.RegisterImporter(
|
|
AImporterClass: TcxPascalScriptImporterClass; const AVirtualUnit: string);
|
|
begin
|
|
if FClassList.IndexOfObject(TObject(AImporterClass)) < 0 then
|
|
FClassList.AddObject(AVirtualUnit, TObject(AImporterClass));
|
|
end;
|
|
|
|
procedure TcxPascalScriptImporterFactory.UnregisterImporter(
|
|
AImporterClass: TcxPascalScriptImporterClass);
|
|
var
|
|
Index: Integer;
|
|
begin
|
|
Index := FClassList.IndexOfObject(TObject(AImporterClass));
|
|
if Index <> -1 then
|
|
FClassList.Delete(Index);
|
|
end;
|
|
|
|
function TcxPascalScriptImporterFactory.GetImporterClass(
|
|
AObjectClass: TClass): TcxPascalScriptImporterClass;
|
|
var
|
|
I: Integer;
|
|
ACurrent: TcxPascalScriptImporterClass;
|
|
begin
|
|
Result := nil;
|
|
if AObjectClass = nil then exit;
|
|
|
|
for I := 0 to FClassList.Count - 1 do
|
|
begin
|
|
ACurrent := TcxPascalScriptImporterClass(FClassList.Objects[I]);
|
|
if AObjectClass.InheritsFrom(ACurrent.ObjectClass) then
|
|
if (Result = nil) or
|
|
not Result.ObjectClass.InheritsFrom(ACurrent.ObjectClass) then
|
|
Result := ACurrent;
|
|
|
|
if (Result <> nil) and (Result.ObjectClass = AObjectClass) then
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
function TcxPascalScriptImporterFactory.GetImporterClass(
|
|
AObject: TObject): TcxPascalScriptImporterClass;
|
|
begin
|
|
if AObject <> nil then
|
|
Result := GetImporterClass(AObject.ClassType)
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
procedure TcxPascalScriptImporterFactory.GetImporterClassList(
|
|
const AUnitName: string; AClassList: TClassList);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
if AUnitName = '' then Exit;
|
|
for I := 0 to FClassList.Count - 1 do
|
|
if SameText(FClassList[I], AUnitName) then
|
|
AClassList.Add(TClass(FClassList.Objects[I]));
|
|
end;
|
|
|
|
initialization
|
|
|
|
finalization
|
|
TcxPascalScriptImporterFactory.ReleaseInstance;
|
|
|
|
end.
|