Files
lazarus-ccr/components/jvcllaz/run/JvPascalInterpreter/JvInterpreterFm.pas
2020-07-10 18:11:22 +00:00

737 lines
22 KiB
ObjectPascal

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvInterpreterFm.PAS, released on 2002-07-04.
The Initial Developers of the Original Code are: Andrei Prygounkov <a dott prygounkov att gmx dott de>
Copyright (c) 1999, 2002 Andrei Prygounkov
All Rights Reserved.
Contributor(s): Ivan Ravin (ivan_ra)
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Description : JVCL Interpreter version 2
Component : form runner for JvInterpreter
Known Issues:
-----------------------------------------------------------------------------}
// $Id$
{ history (JVCL Library versions):
1.10:
- first release;
1.12:
- more smart interface-part reducementer -
method MakeCompatibleUnit;
1.31.3 (JVCL Library 1.31 with update 3):
- support for Delphi5 text DFM files.
1.52:
- fixed memory bug;
1.52.4:
- previous memory bug fix was moved to JvInterpreter.pas unit;
1.60:
- forms, placed in used units, are supported;
- method MakeCompatibleUnit has been removed;
1.61:
- fixed bug: local variables in methods overrieded by form memebers;
this bug prevented MDI forms from "Action := caFree" code to work
(thanks to Ivan Ravin);
2.00:
- loading of inherited forms added by Cerny Robert;
}
unit JvInterpreterFm;
{$mode Delphi}
interface
uses
SysUtils, Classes, Controls, Forms,
JvInterpreter;
type
TJvInterpreterGetDfmFileName = procedure(Sender: TObject; UnitName: string;
var FileName: string; var Done: Boolean) of object;
TJvInterpreterCreateDfmStream = procedure(Sender: TObject; UnitName: string;
var Stream: TStream; var Done: Boolean) of object;
TJvInterpreterFreeDfmStream = procedure(Sender: TObject; Stream: TStream) of object;
TJvInterpreterFm = class;
TJvInterpreterForm = class(TForm) //TJvForm)
private
FJvInterpreterFm: TJvInterpreterFm;
FMethodList: TList;
FFieldList: TJvInterpreterVarList;
FFreeJvInterpreterFm: Boolean;
FClassIdentifier: string;
FUnitName: string;
procedure FixupMethods;
protected
procedure ReadState(Reader: TReader); override;
property MethodList: TList read FMethodList;
property ClassIdentifier: string read FClassIdentifier;
{$WARNINGS OFF} // Delphi 2009+ has a class function UnitName
property UnitName: string read FUnitName;
{$WARNINGS ON}
public
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
destructor Destroy; override;
property JvInterpreterFm: TJvInterpreterFm read FJvInterpreterFm write FJvInterpreterFm;
end;
TJvInterpreterFm = class(TJvInterpreterProgram)
private
FForm: TJvInterpreterForm;
FFileName: string;
FInterfaceUses: Boolean;
FOnGetDfmFileName: TJvInterpreterGetDfmFileName;
FOnCreateDfmStream: TJvInterpreterCreateDfmStream;
FOnFreeDfmStream: TJvInterpreterFreeDfmStream;
procedure LoadForm(AForm: TJvInterpreterForm);
protected
function GetValue(const Identifier: string; var Value: Variant;
var Args: TJvInterpreterArgs): Boolean; override;
function SetValue(const Identifier: string; const Value: Variant;
var Args: TJvInterpreterArgs): Boolean; override;
function GetUnitSource(const UnitName: string; var Source: string): Boolean; override;
procedure CreateDfmStream(const UnitName: string; var Stream: TStream); dynamic;
procedure FreeDfmStream(Stream: TStream); dynamic;
public
procedure Run; override;
function MakeForm(const FileName: TFileName): TForm;
function MakeInheritedForm(F: TJvInterpreterForm; const FileName: TFileName): TForm;
function RunForm(const FileName: TFileName): TForm;
function RunFormModal(const FileName: TFileName): TModalResult;
function RunUnit(const FileName: TFileName): Variant;
procedure RunReportPreview(const FileName: string);
property Form: TJvInterpreterForm read FForm;
property FileName: string read FFileName;
published
property OnGetDfmFileName: TJvInterpreterGetDfmFileName read FOnGetDfmFileName write FOnGetDfmFileName;
property OnCreateDfmStream: TJvInterpreterCreateDfmStream read FOnCreateDfmStream write FOnCreateDfmStream;
property OnFreeDfmStream: TJvInterpreterFreeDfmStream read FOnFreeDfmStream write FOnFreeDfmStream;
property InterfaceUses: Boolean read FInterfaceUses write FInterfaceUses default False;
end;
function JvInterpreterRunFormModal(const AFileName: TFileName): TModalResult;
function JvInterpreterRunForm(const AFileName: TFileName): TForm;
function JvInterpreterMakeForm(const AFileName: TFileName): TForm;
function JvInterpreterRunUnit(const AFileName: TFileName): Variant;
procedure JvInterpreterRunReportPreview(const AFileName: string);
procedure JvInterpreterRunReportPreview2(const AFileName: string; JvInterpreterProgram: TJvInterpreterFm);
procedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);
const
ieImplementationNotFound = 401;
var
JvInterpreterRunReportPreviewProc: procedure(const FileName: string);
JvInterpreterRunReportPreview2Proc: procedure(const FileName: string; JvInterpreterProgram: TJvInterpreterFm);
implementation
uses
Variants, TypInfo, LazFileUtils,
JvResources, JvTypes, JvJCLUtils;
//=== { TJvInterpreterReader } ===============================================
type
TJvInterpreterReader = class(TReader)
protected
function FindMethod(Root: TComponent; const MethodName: string): Pointer;
override;
end;
TJvInterpreterAdapterAccessProtected = class(TJvInterpreterAdapter);
function TJvInterpreterReader.FindMethod(Root: TComponent; const MethodName: string): Pointer;
var
Len: Integer;
begin
// (rom) explicit allocation instead of deprecated NewStr
Len := Length(MethodName) + 1;
GetMem(Result, Len * SizeOf(Char));
Move(PChar(MethodName)^, Result^, Len * SizeOf(Char));
TJvInterpreterForm(Root).FMethodList.Add(Result);
end;
//=== { TJvInterpreterForm } =================================================
constructor TJvInterpreterForm.CreateNew(AOwner: TComponent; Dummy: Integer = 0);
begin
FMethodList := TList.Create;
FFieldList := TJvInterpreterVarList.Create; // class fields suport
{$IFDEF DELPHI}
inherited CreateNew(AOwner);
{$ELSE}
inherited CreateNew(AOwner, Dummy);
{$ENDIF DELPHI}
end;
destructor TJvInterpreterForm.Destroy;
var
I: Integer;
begin
for I := 0 to FMethodList.Count - 1 do
FreeMem(FMethodList[I]);
FMethodList.Free;
FFieldList.Free; // class fields suport
inherited Destroy;
if FFreeJvInterpreterFm then
FJvInterpreterFm.Free;
end;
procedure TJvInterpreterForm.FixupMethods;
procedure ReadProps(Com: TComponent);
var
TypeInf: PTypeInfo;
TypeData: PTypeData;
PropList: PPropList;
NumProps: Word;
I: Integer;
F: Integer;
Method: TMethod;
begin
TypeInf := Com.ClassInfo;
TypeData := GetTypeData(TypeInf);
NumProps := TypeData^.PropCount;
GetMem(PropList, NumProps * SizeOf(Pointer));
try
GetPropInfos(TypeInf, PropList);
for I := 0 to NumProps - 1 do
if PropList^[I].PropType^.Kind = tkMethod then
begin
Method := GetMethodProp(Com, PropList^[I]);
if Method.Data = Self then
begin
F := FMethodList.IndexOf(Method.Code);
if F > -1 then
begin
SetMethodProp(Com, PropList^[I],
TMethod(FJvInterpreterFm.NewEvent(FUnitName,
PChar(FMethodList[F]),
{$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropList^[I]^.PropType^.Name),
Self,
{$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropList^[I]^.Name))));
end;
end;
end;
finally
FreeMem(PropList);
end;
end;
var
I: Integer;
begin
if FJvInterpreterFm = nil then
Exit; {+RWare}
ReadProps(Self);
for I := 0 to ComponentCount - 1 do
ReadProps(Components[I]);
end;
procedure TJvInterpreterForm.ReadState(Reader: TReader);
begin
inherited ReadState(Reader);
FixupMethods;
end;
function JvInterpreterReadComponentRes(var Stream: TStream;
Instance: TComponent): TComponent;
var
JvInterpreterReader: TJvInterpreterReader;
TmpStream: TMemoryStream;
begin
(**************** NOT CONVERTED ****
if TestStreamFormat(Stream) = sofText then
begin
***********************************)
TmpStream := TMemoryStream.Create;
ObjectTextToResource(Stream, TmpStream);
Stream.Free;
Stream := TmpStream;
Stream.Position := 0;
(*****************
end;
******************)
Stream.ReadResHeader;
JvInterpreterReader := TJvInterpreterReader.Create(Stream, 4096);
try
Result := JvInterpreterReader.ReadRootComponent(Instance);
finally
JvInterpreterReader.Free;
end;
end;
//=== { TJvInterpreterFm } ===================================================
function TJvInterpreterFm.MakeForm(const FileName: TFileName): TForm;
var
S: string = '';
UnitName: string;
begin
FFileName := FileName;
UnitName := ChangeFileExt(ExtractFileName(FFileName), '');
if not (GetUnitSource(FFileName, S) or GetUnitSource(UnitName, S)) then
JvInterpreterErrorN(ieUnitNotFound, -1, UnitName);
Source := S;
Compile;
FForm := TJvInterpreterForm.CreateNew(Application);
FForm.FUnitName := UnitName;
LoadForm(FForm);
Result := FForm;
end; { MakeForm }
function TJvInterpreterFm.MakeInheritedForm(F: TJvInterpreterForm; const FileName: TFileName): TForm;
var
S: string = '';
UnitName: string;
begin
FFileName := FileName;
UnitName := ChangeFileExt(ExtractFileName(FFileName), '');
if not (GetUnitSource(FFileName, S) or GetUnitSource(UnitName, S)) then
JvInterpreterErrorN(ieUnitNotFound, -1, UnitName);
Source := S;
Compile;
FForm := F;
FForm.FUnitName := UnitName;
LoadForm(FForm);
Result := FForm;
end;
procedure TJvInterpreterFm.CreateDfmStream(const UnitName: string; var Stream: TStream);
var
Done: Boolean;
DfmFile: string = '';
begin
Done := False;
if Assigned(FOnCreateDfmStream) then
FOnCreateDfmStream(Self, UnitName, Stream, Done);
if not Done then
begin
if Assigned(FOnGetDfmFileName) then
FOnGetDfmFileName(Self, UnitName, DfmFile, Done);
if not Done then
DfmFile := FindInPath(ChangeFileExt(UnitName, '.dfm'), ExtractFilePath(FFileName));
Done := FileExists(DfmFile);
if Done then
Stream := TFileStream.Create(DfmFile, fmOpenRead);
end;
if not Done then
JvInterpreterErrorN(ieDfmNotFound, -1, UnitName);
end;
procedure TJvInterpreterFm.FreeDfmStream(Stream: TStream);
begin
if Assigned(FOnFreeDfmStream) then
FOnFreeDfmStream(Self, Stream)
else
Stream.Free;
end;
procedure TJvInterpreterFm.LoadForm(AForm: TJvInterpreterForm);
var
Stream: TStream = nil;
SrcClass: TJvInterpreterIdentifier; // Class Fields support
i: integer;
begin
FForm := AForm;
Form.FJvInterpreterFm := Self;
CreateDfmStream(FForm.FUnitName, Stream);
try
JvInterpreterReadComponentRes(Stream, Form);
finally
FreeDfmStream(Stream);
end;
// find form class
if AForm.FClassIdentifier = '' then
for i:=0 to Adapter.SrcClassList.Count-1 do
if cmp(TJvInterpreterIdentifier(Adapter.SrcClassList[i]).UnitName,FForm.FUnitName) then
begin
FForm.FClassIdentifier := TJvInterpreterIdentifier(Adapter.SrcClassList[i]).Identifier;
Break;
end;
// Class Fields support begin
// copy form fields from pattern
SrcClass := TJvInterpreterAdapterAccessProtected(Adapter).GetSrcClass(
AForm.FClassIdentifier);
if assigned(SrcClass) then
AForm.FFieldList.Assign(TJvInterpreterClass(SrcClass).ClassFields);
// Class Fields support end
try
if Assigned(Form.OnCreate) then
Form.OnCreate(Form);
except
Application.HandleException(Form);
end;
if Form.FormStyle <> fsMDIChild then
Form.Visible := False;
end;
function TJvInterpreterFm.GetValue(const Identifier: string; var Value: Variant;
var Args: TJvInterpreterArgs): Boolean;
var
JvInterpreterSrcClass: TJvInterpreterIdentifier;
JvInterpreterForm: TJvInterpreterForm;
LocalArgs: TJvInterpreterArgs;
function GetFromForm(Form: TJvInterpreterForm): Boolean;
var
Com: TComponent;
begin
if Cmp(Identifier, 'Self') then
begin
Value := O2V(Form);
Result := True;
Exit;
end;
Com := Form.FindComponent(Identifier);
if Com = nil then
begin
if (LocalVars <> nil) and (LocalVars.FindVar('', Identifier) <> nil) then
begin
Result := LocalVars.GetValue(Identifier, Value, Args);
Exit;
end;
// Class Fields support begin
with Form.FFieldList do
if FindVar('', Identifier) <> nil then
begin
Args.Obj:=nil;
Result := GetValue(Identifier, Value, Args);
Exit;
end;
// Class Fields support end
{ may be TForm method or published property }
Args.Obj := Form;
Args.ObjTyp := varObject;
try
Result := inherited GetValue(Identifier, Value, Args);
finally
Args.Obj := nil;
Args.ObjTyp := 0;
end;
end
else
begin
Value := O2V(Com);
Result := True;
end;
end;
begin
if (Args.Obj = nil) and (CurInstance is TJvInterpreterForm) then
Result := GetFromForm(CurInstance as TJvInterpreterForm)
else
if (Args.Obj <> nil) and (Args.ObjTyp = varObject) and
(Args.Obj is TJvInterpreterForm) then
begin
{ run-time form creation }
if Cmp(Identifier, 'Create') then
begin
// setting form's Owner from expression 'create(newOwner)'
// when Identifier = 'Create' then Token = 'newOwner'
JvInterpreterForm := Args.Obj as TJvInterpreterForm;
LocalArgs := TJvInterpreterArgs.Create;
try
LocalArgs.Obj:=Args.Obj;
LocalArgs.ObjTyp:=Args.ObjTyp;
GetValue(Token, Value, LocalArgs);
finally
LocalArgs.Free;
end;
if V2O(Value)<>JvInterpreterForm.Owner then begin
if JvInterpreterForm.Owner<>nil then
JvInterpreterForm.Owner.RemoveComponent(JvInterpreterForm);
if V2O(Value)<>nil then
TComponent(V2O(Value)).InsertComponent(JvInterpreterForm);
end;
JvInterpreterSrcClass := TJvInterpreterAdapterAccessProtected(Adapter).GetSrcClass(
JvInterpreterForm.FClassIdentifier);
JvInterpreterForm.FUnitName := JvInterpreterSrcClass.UnitName;
LoadForm(JvInterpreterForm);
Value := O2V(Args.Obj);
Result := True;
Exit;
end
else
Result := GetFromForm(Args.Obj as TJvInterpreterForm)
end
else
Result := False;
if Result then
Exit;
{ run-time form creation }
JvInterpreterSrcClass := TJvInterpreterAdapterAccessProtected(Adapter).GetSrcClass(Identifier);
if JvInterpreterSrcClass <> nil then
begin
JvInterpreterForm := TJvInterpreterForm.CreateNew(Application);
JvInterpreterForm.FClassIdentifier := Identifier;
Value := O2V(JvInterpreterForm);
Result := True;
Exit;
end;
Result := Result or inherited GetValue(Identifier, Value, Args);
end;
function TJvInterpreterFm.SetValue(const Identifier: string; const Value: Variant;
var Args: TJvInterpreterArgs): Boolean;
// Class Fields support begin
var
JvInterpreterForm: TJvInterpreterForm;
function SetFormValue(Form: TJvInterpreterForm): Boolean;
begin
Result := False;
with Form.FFieldList do
if FindVar('', Identifier) <> nil then begin
Args.Obj := nil;
Result := SetValue(Identifier, Value, Args);
end;
end;
// Class Fields support end
begin
if (Args.Obj = nil) and (CurInstance is TJvInterpreterForm) then
begin
if (LocalVars <> nil) and (LocalVars.FindVar('', Identifier) <> nil) then
begin
Result := LocalVars.SetValue(Identifier, Value, Args);
Exit;
end;
// Class Fields support begin
{ may be TForm field }
Result := SetFormValue(TJvInterpreterForm(CurInstance));
if not Result then
begin
// Class Fields support end
{ may be TForm method or published property }
Args.Obj := CurInstance;
Args.ObjTyp := varObject;
try
Result := inherited SetValue(Identifier, Value, Args);
finally
Args.Obj := nil;
Args.ObjTyp := 0;
end;
end;
end
// Class Fields support begin
else
if (Args.Obj <> nil) and (Args.ObjTyp = varObject) and
(Args.Obj is TJvInterpreterForm) then
begin
JvInterpreterForm := TJvInterpreterForm(Args.Obj);
try
Args.Obj := nil;
Result := SetFormValue(JvInterpreterForm);
finally
Args.Obj := JvInterpreterForm;
end;
end
// Class Fields support end
else
Result := False;
Result := Result or inherited SetValue(Identifier, Value, Args);
end;
function TJvInterpreterFm.GetUnitSource(const UnitName: string; var Source: string): Boolean;
var
FN: TFileName;
begin
if not FInterfaceUses and (UnitSection = usInterface) then
begin
Source := 'unit ' + UnitName + '; end.';
Result := True;
end
else
begin
Result := inherited GetUnitSource(UnitName, Source);
if not Result then
begin
if ExtractFileExt(UnitName) = '' then
FN := UnitName + '.pas'
else
FN := UnitName;
Result := FileExists(FN);
if not Result then
begin
FN := FindInPath(ExtractFileName(FN), ExtractFilePath(FFileName));
Result := FileExists(FN);
end;
if Result then
Source := LoadTextFile(FN)
end;
end;
end;
procedure TJvInterpreterFm.Run;
begin
inherited Run;
end;
function TJvInterpreterFm.RunForm(const FileName: TFileName): TForm;
begin
Result := MakeForm(FileName);
Result.Show;
end;
function TJvInterpreterFm.RunFormModal(const FileName: TFileName): TModalResult;
begin
with MakeForm(FileName) do
try
Result := ShowModal;
finally
Free;
end;
end;
function TJvInterpreterFm.RunUnit(const FileName: TFileName): Variant;
var
UnitName: string;
S: string = '';
begin
FFileName := FileName;
try
UnitName := ChangeFileExt(ExtractFileName(FFileName), '');
if not (GetUnitSource(FFileName, S) or GetUnitSource(UnitName, S)) then
JvInterpreterErrorN(ieUnitNotFound, -1, UnitName);
Source := S;
except
JvInterpreterErrorN(ieUnitNotFound, -1, FFileName);
end;
Run;
end;
procedure TJvInterpreterFm.RunReportPreview(const FileName: string);
begin
JvInterpreterRunReportPreview2(FileName, Self);
end;
function JvInterpreterRunFormModal(const AFileName: TFileName): TModalResult;
var
TmpInterpreterFm: TJvInterpreterFm;
begin
TmpInterpreterFm := TJvInterpreterFm.Create(Application);
try
Result := TmpInterpreterFm.RunFormModal(AFileName);
finally
TmpInterpreterFm.Free;
end;
end;
function JvInterpreterRunForm(const AFileName: TFileName): TForm;
var
TmpInterpreterFm: TJvInterpreterFm;
begin
TmpInterpreterFm := TJvInterpreterFm.Create(Application);
begin
Result := TmpInterpreterFm.RunForm(AFileName);
(Result as TJvInterpreterForm).FFreeJvInterpreterFm := True;
end;
end;
function JvInterpreterMakeForm(const AFileName: TFileName): TForm;
var
TmpInterpreterFm: TJvInterpreterFm;
begin
TmpInterpreterFm := TJvInterpreterFm.Create(Application);
begin
Result := TmpInterpreterFm.MakeForm(AFileName);
(Result as TJvInterpreterForm).FFreeJvInterpreterFm := True;
end;
end;
function JvInterpreterRunUnit(const AFileName: TFileName): Variant;
var
TmpInterpreterFm: TJvInterpreterFm;
begin
TmpInterpreterFm := TJvInterpreterFm.Create(Application);
try
Result := TmpInterpreterFm.RunUnit(AFileName);
finally
TmpInterpreterFm.Free;
end;
end;
{ adapter to self }
{ function JvInterpreterRunFormModal(const FileName: TFileName): TModalResult; }
procedure JvInterpreter_JvInterpreterRunFormModal(var Value: Variant; Args: TJvInterpreterArgs);
begin
Value := JvInterpreterRunFormModal(VarToStr(Args.Values[0]));
end;
{ function JvInterpreterRunForm(const FileName: TFileName): TForm; }
procedure JvInterpreter_JvInterpreterRunForm(var Value: Variant; Args: TJvInterpreterArgs);
begin
Value := O2V(JvInterpreterRunForm(VarToStr(Args.Values[0])));
end;
{ function JvInterpreterMakeForm(const FileName: TFileName): TForm; }
procedure JvInterpreter_JvInterpreterMakeForm(var Value: Variant; Args: TJvInterpreterArgs);
begin
Value := O2V(JvInterpreterMakeForm(VarToStr(Args.Values[0])));
end;
{ function JvInterpreterRunUnit(const FileName: TFileName): Variant }
procedure JvInterpreter_JvInterpreterRunUnit(var Value: Variant; Args: TJvInterpreterArgs);
begin
Value := JvInterpreterRunUnit(VarToStr(Args.Values[0]));
end;
procedure JvInterpreterRunReportPreview(const AFileName: string);
begin
if not Assigned(JvInterpreterRunReportPreviewProc) then
raise EJVCLException.CreateRes(@RsENoReportProc);
JvInterpreterRunReportPreviewProc(AFileName);
end;
procedure JvInterpreterRunReportPreview2(const AFileName: string; JvInterpreterProgram: TJvInterpreterFm);
begin
if not Assigned(JvInterpreterRunReportPreview2Proc) then
raise EJVCLException.CreateRes(@RsENoReportProc2);
JvInterpreterRunReportPreview2Proc(AFileName, JvInterpreterProgram);
end;
procedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);
const
cJvInterpreterFm = 'JvInterpreterFm';
begin
with JvInterpreterAdapter do
begin
AddFunction(cJvInterpreterFm, 'JvInterpreterRunFormModal', JvInterpreter_JvInterpreterRunFormModal, 1, [varString],
varEmpty);
AddFunction(cJvInterpreterFm, 'JvInterpreterRunForm', JvInterpreter_JvInterpreterRunForm, 1, [varString], varEmpty);
AddFunction(cJvInterpreterFm, 'JvInterpreterMakeForm', JvInterpreter_JvInterpreterMakeForm, 1, [varString], varEmpty);
AddFunction(cJvInterpreterFm, 'JvInterpreterRunUnit', JvInterpreter_JvInterpreterRunUnit, 1, [varString], varEmpty);
end;
end;
end.