jvinterpreterfm.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
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):

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:
-----------------------------------------------------------------------------}
// $Id: JvInterpreterFm.pas,v 1.25 2005/02/17 10:20:38 marquardt Exp $

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

{$I jvcl.inc}

interface

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  SysUtils, Classes, Controls, Forms,
  JvInterpreter, JvJVCLUtils;

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;
    property MethodList: TList read  FMethodList;
    property ClassIdentifier: string read FClassIdentifier;
    property UnitName: string read FUnitName;
  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 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);

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvInterpreterFm.pas,v $';
    Revision: '$Revision: 1.25 $';
    Date: '$Date: 2005/02/17 10:20:38 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  TypInfo,
  JvResources, JvTypes, JvJCLUtils;

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;

  TJvInterpreterAdapterAccessProtected = 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 } =================================================

constructor TJvInterpreterForm.CreateNew(AOwner: TComponent; Dummy: Integer = 0);
begin
  FMethodList := TList.Create;
  {$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;
  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]), PropList^[I]^.PropType^.Name, Self, PropList^[I]^.Name)));
            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;
  TmpStream: TMemoryStream;
begin
  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;