rm_jvinterpreterfm.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 720 行 · 第 1/2 页

{-----------------------------------------------------------------------------
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 <[e-mail]>
Copyright (c) 1999, 2002 Andrei Prygounkov
All Rights Reserved.

Contributor(s):

Last Modified: 2002-07-04

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Description : JVCL Interpreter version 2
Component   : form runner for JvInterpreter

Known Issues:
-----------------------------------------------------------------------------}

{$I rm_JVCL.INC}

{ 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 rm_JvInterpreterFm;

interface

uses
  SysUtils, Classes, Controls, Forms,
  rm_JvInterpreter, rm_JvUtils;

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)
  private
    FJvInterpreterFm: TJvInterpreterFm;
    FMethodList: TList;
    FFreeJvInterpreterFm: Boolean;
    FClassIdentifier: string;
    FUnitName: string;
    procedure FixupMethods;
  protected
    procedure ReadState(Reader: TReader); override;
  public
    {$IFDEF COMPILER4_UP}
    constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
    {$ELSE}
    constructor CreateNew(AOwner: TComponent; Dummy: Integer);
    {$ENDIF COMPILER4_UP}
    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(Identifier: string; var Value: Variant;
      var Args: TJvInterpreterArgs): Boolean; override;
    function SetValue(Identifier: string; const Value: Variant;
      var Args: TJvInterpreterArgs): Boolean; override;
    function GetUnitSource(UnitName: string; var Source: string): Boolean;
      override;
    procedure CreateDfmStream(const UnitName: string; var Stream: TStream); dynamic;
    procedure FreeDfmStream(Stream: TStream); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    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;
  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 FileName: TFileName): TModalResult;
function JvInterpreterRunForm(const FileName: TFileName): TForm;
function JvInterpreterMakeForm(const FileName: TFileName): TForm;
function JvInterpreterRunUnit(const FileName: TFileName): Variant;
procedure JvInterpreterRunReportPreview(const FileName: string);
procedure JvInterpreterRunReportPreview2(const FileName: 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
  TypInfo,
  rm_JvInterpreterConst, rm_JvStrUtil;

function LoadTextFile(const FileName: TFileName): string;
begin
  with TStringList.Create do
  try
    LoadFromFile(FileName);
    Result := Text;
  finally
    Free;
  end;
end;

function AddSlash2(const Dir: TFileName): string;
begin
  Result := Dir;
  if (Length(Dir) > 0) and (Dir[Length(Dir)] <> '\') then
    Result := Dir + '\';
end;

function FindInPath(const FileName, PathList: string): TFileName;
var
  I: Integer;
  S: string;
begin
  I := 0;
  S := SubStr(PathList, I, ';');
  while S <> '' do
  begin
    Result := AddSlash2(S) + FileName;
    if FileExists(Result) then
      Exit;
    Inc(I);
    S := SubStr(PathList, I, ';');
  end;
  Result := '';
end;

//=== TJvInterpreterReader ===================================================

type
  TJvInterpreterReader = class(TReader)
  protected
    function FindMethod(Root: TComponent; const MethodName: string): Pointer;
      override;
  end;

  THackAdapter = class(TJvInterpreterAdapter);

function TJvInterpreterReader.FindMethod(Root: TComponent;
  const MethodName: string): Pointer;
var
  Len: Integer;
begin
  // (rom) explicit allocation instead of deprecated NewStr
  Len := StrLen(PChar(MethodName))+1;
  GetMem(Result, Len);
  Move(PChar(MethodName)^, Result^, Len);
  TJvInterpreterForm(Root).FMethodList.Add(Result);
end;

//=== TJvInterpreterForm =====================================================

{$IFDEF COMPILER4_UP}
constructor TJvInterpreterForm.CreateNew(AOwner: TComponent; Dummy: Integer = 0);
{$ELSE}
constructor TJvInterpreterForm.CreateNew(AOwner: TComponent; Dummy: Integer);
{$ENDIF COMPILER4_UP}
begin
  FMethodList := TList.Create;
  {$IFDEF Delphi}
  inherited CreateNew(AOwner);
  {$ELSE}
  inherited CreateNew(AOwner, Dummy);
  {$ENDIF}
end;

destructor TJvInterpreterForm.Destroy;
var
  I: Integer;
begin
  for I := 0 to FMethodList.Count - 1 do
    FreeMem(FMethodList[I]);
  FMethodList.Free;
  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]){PString(FMethodList[F])^}, PropList^[I]^.PropType^.Name, Self)));
            end;
          end;
        end;
    finally
      FreeMem(PropList, NumProps * sizeof(pointer));
    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;
  {$IFDEF COMPILER5_UP}
  TmpStream: TMemoryStream;
  {$ENDIF COMPILER5_UP}
begin
  {$IFDEF COMPILER5_UP}
  if TestStreamFormat(Stream) = sofText then
  begin
    TmpStream := TMemoryStream.Create;
    ObjectTextToResource(Stream, TmpStream);
    Stream.Free;
    Stream := TmpStream;
    Stream.Position := 0;
  end;
  {$ENDIF COMPILER5_UP}

  Stream.ReadResHeader;
  JvInterpreterReader := TJvInterpreterReader.Create(Stream, 4096);
  try
    Result := JvInterpreterReader.ReadRootComponent(Instance);
  finally
    JvInterpreterReader.Free;
  end;
end;

//=== TJvInterpreterFm =======================================================

constructor TJvInterpreterFm.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
end;

destructor TJvInterpreterFm.Destroy;
begin
  inherited Destroy;
end;

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;
  {$IFDEF COMPILER4_UP}
  FForm := TJvInterpreterForm.CreateNew(Application);
  {$ELSE}
  FForm := TJvInterpreterForm.CreateNew(Application, 0);
  {$ENDIF COMPILER4_UP}
  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);