base_dfm.pas

来自「Delphi脚本控件」· PAS 代码 · 共 2,003 行 · 第 1/4 页

////////////////////////////////////////////////////////////////////////////
// PAXScript Interpreter
// Author: Alexander Baranovsky ([e-mail])
// ========================================================================
// Copyright (c) Alexander Baranovsky, 2003-2005. All rights reserved.
// Code Version: 3.0
// ========================================================================
// Unit: BASE_DFM.pas
// ========================================================================
////////////////////////////////////////////////////////////////////////////

{$I PaxScript.def}
unit BASE_DFM;

interface

uses
{$IFDEF WIN32}
  Windows,
{$ENDIF}
  TypInfo,
  SysUtils,
  Classes,
  BASE_SYS;

procedure ConvertDfmFile(const DfmFileName: String; UsedUnits, Output: TStrings;
                         AsUnit: Boolean = true; const Src: TStrings = nil; const PaxLanguage: String = 'paxPascal');
procedure ConvertXfmFile(const XfmFileName: String; UsedUnits, Output: TStrings;
                         AsUnit: Boolean = true; const Src: TStrings = nil; const PaxLanguage: String = 'paxPascal');
procedure SaveStr(S, FileName: String);
procedure RegisterUsedClasses;
procedure ConvDFMStringtoScript(const s: String; UsedUnits, Output: TStrings; AsUnit: Boolean = true;
                                const UnitName: String = ''; const Src: TStrings = nil; const PaxLanguage: String = 'paxPascal');

procedure ConvDFMToPaxPascalScript(const DfmFileName: String; ms: TStream; UsedUnits, Output: TStrings; AsUnit: Boolean = true;
                          Src: TStrings = nil);
procedure ConvDFMToPaxBasicScript(const DfmFileName: String; ms: TStream; UsedUnits, Output: TStrings; AsUnit: Boolean = true;
                          Src: TStrings = nil);
procedure ConvDFMToPaxCScript(const DfmFileName: String; ms: TStream; UsedUnits, Output: TStrings; AsUnit: Boolean = true;
                              Src: TStrings = nil);
procedure ConvDFMToPaxJavaScriptScript(const DfmFileName: String; ms: TStream; UsedUnits, Output: TStrings;
                          AsUnit: Boolean = false;
                          Src: TStrings = nil);

implementation

function _InheritsFrom(const ClassName1, ClassName2: String): Boolean;
var
  Class1, Class2: TClass;
begin
  result := false;
  Class1 := GetClass(ClassName1);
  if Class1 = nil then
    Exit;
  Class2 := GetClass(ClassName2);
  if Class2 = nil then
    Exit;
  result := Class1.InheritsFrom(Class2);
end;

const
  AP = '''';
  AP2 = '"';

function InsAssignment(const S: String; var Failure: boolean): String;
var
  P: Integer;
begin
  result := S;
  P := Pos(' = ', S);
  if P > 0 then
  begin
    Insert(':', result, P + 1);
    Failure := false;
  end
  else
    Failure := true;
end;

function StartBinData(const S: String): boolean;
begin
  if Length(S) = 0 then
    result := false
  else
    result := S[Length(S)] = '{';
end;

function ContinueBinData(const S: String): boolean;
begin
  if Length(S) = 0 then
    result := false
  else
    result := (S[1] in ['0'..'9','A'..'F']) and (Pos('=', S) = 0) and
                                                (Pos('}', S) = 0);
end;

function EndBinData(const S: String): boolean;
begin
  if Length(S) = 0 then
    result := false
  else
    result := S[Length(S)] = '}';
end;

function StartStringData(const S: String): boolean;
begin
  if Length(S) = 0 then
    result := false
  else
    result := S[Length(S)] = '(';
end;

function ContinueStringData(const S: String): boolean;
begin
  if Length(S) = 0 then
    result := false
  else
    result := (S[1] = AP) and (Pos('=', S) = 0) and
                              (Pos(')', S) = 0);
end;

function EndStringData(const S: String): boolean;
begin
  if Length(S) = 0 then
    result := false
  else
    result := S[Length(S)] = ')';
end;

var
  OBJECT_SWITCH: boolean = false;
  COLLECTION_ITEM_SWITCH: boolean = false;
  ObjName: String;

function StartCollectionItem(const S: String): boolean;
begin
  result := StrEql(S, 'item') and OBJECT_SWITCH;
  if result then
    COLLECTION_ITEM_SWITCH := true;
end;

function EndCollectionItem(const S: String): boolean;
begin
  result := (StrEql(S, 'end') or StrEql(S, 'end>')) and COLLECTION_ITEM_SWITCH;
  if result then
    COLLECTION_ITEM_SWITCH := false;
end;

function StartObjectData(const S: String): boolean;
begin
  if Length(S) = 0 then
    result := false
  else
    result := S[Length(S)] = '<';

  if result then
  begin
    OBJECT_SWITCH := true;
    ObjName := Trim(Copy(S, 1, Pos('=', S) - 1));
  end;
end;

function EndObjectData(const S: String): boolean;
begin
  if Length(S) = 0 then
    result := false
  else
    result := S[Length(S)] = '>';

  if result then
    OBJECT_SWITCH := false;
end;

function ContinueObjectData(const S: String): boolean;
begin
  result := OBJECT_SWITCH and (not EndObjectData(S));

  if result then
    result := result;
end;

procedure ConvDFMtoScript(const DfmFileName: String; ms: TStream; UsedUnits, Output: TStrings; AsUnit: Boolean = true;
                          Src: TStrings = nil; const PaxLanguage: String = 'paxPascal');
begin
  if PaxLanguage = 'paxPascal' then
    ConvDfmToPaxPascalScript(DfmFileName, ms, UsedUnits, Output, AsUnit, Src)
  else if PaxLanguage = 'paxC' then
    ConvDfmToPaxCScript(DfmFileName, ms, UsedUnits, Output, AsUnit, Src)
  else if PaxLanguage = 'paxBasic' then
    ConvDfmToPaxBasicScript(DfmFileName, ms, UsedUnits, Output, AsUnit, Src)
  else if PaxLanguage = 'paxJavaScript' then
    ConvDfmToPaxJavaScriptScript(DfmFileName, ms, UsedUnits, Output, false, Src);
end;

function ExtractAncestorClassName(L: TStrings): String;
var
  I, P1, P2: Integer;
  S: String;
begin
  result := 'TForm';
  if L = nil then Exit;

  for I:=0 to L.Count - 1 do
  begin
    S := TRIM(UpperCase(L[I]));
    P1 := Pos('CLASS(', S);
    if P1 > 0 then
    begin
      P2 := Pos(')', S);
      if P2 > 0 then
      begin
        result := Copy(S, P1 + 6, P2 - P1 - 6);
        Exit;
      end;
    end;
  end;
end;

////////////////  PAX PASCAL //////////////////////////////////

procedure ConvDFMToPaxPascalScript(const DfmFileName: String; ms: TStream; UsedUnits, Output: TStrings; AsUnit: Boolean = true;
                          Src: TStrings = nil);
var
  I, J, J1: Integer;
  InputList: TStringList;
  S, ClassName, FormName, Indent,
  AnObject, AClass, SaveObject: String;
  Failure: boolean;
  C: TClass;
  MainPropList: TStringList;

  K: Integer;
  StackObj, StackCls: array[1..100] of String;
  Pos_S: Integer;
  Need_S: Boolean;
  UnitName: String;

  searchStr, headerStr: String;
  IsEvent: Boolean;
  PosConstructor: Integer;
  EventHandlerList: TStringList;
  HeaderList: TStringList;

  AncestorClassName: String;
  isInherited: Boolean;
begin
  PosConstructor := 0;

  UnitName := DfmFileName;
  I := Pos('.', DfmFileName);
  if I > 0 then
    UnitName := Copy(UnitName, 1, I - 1);

  RegisterUsedClasses;

  InputList := TStringList.Create;
  MainPropList := TStringList.Create;
  EventHandlerList := TStringList.Create;
  HeaderList := TStringList.Create;

  Need_S := false;

  try
    ms.Seek(0, 0);
    InputList.LoadFromStream(ms);

    for I:=0 to InputList.Count - 1 do
    begin
      S := TrimLeft(InputList[I]) + ' ';
      if StrEql('object ', Copy(S, 1, 7)) then
      begin
        S := TrimRight(Copy(S, Pos(':', S) + 1, 100));
        ClassName := Trim(S);
        break;
      end;
    end;

    for I:=UsedUnits.Count - 1 downto 0 do
    begin
      S := Trim(UsedUnits[I]);
      if S = '' then
        UsedUnits.Delete(I);
    end;

    if AsUnit then
    begin
      Output.Add('unit ' + UnitName + ';');
      Output.Add('interface');
    end;

    if UsedUnits.Count > 0 then
    begin
      Output.Add('uses');
      for I:=0 to UsedUnits.Count - 1 do
      begin
        S := Trim(UsedUnits[I]);
        if I = UsedUnits.Count - 1 then
          Output.Add('  ' + S + ';')
        else
          Output.Add('  ' + S + ',');
      end;
    end;

    K := 0;

    Indent := '  ';

    for I:=0 to InputList.Count - 1 do
    begin
      if I = 0 then
        Output.Add('type');

      S := TrimLeft(InputList[I]) + ' ';

      if      StartObjectData(TrimRight(S)) then
        continue
      else if EndObjectData(TrimRight(S)) then
        continue
      else if ContinueObjectData(TrimRight(S)) then
        continue
      else if StrEql('object ', Copy(S, 1, 7)) or StrEql('inherited ', Copy(S, 1, 10)) then
      begin
        AncestorClassName := 'TForm';
        IsInherited := false;

        if Pos('inherited ', S) = 1 then
        begin
          IsInherited := true;
          S := StringReplace(S, 'inherited ', 'object ', []);
          AncestorClassName := Copy(S, Pos(':', S) + 1, Length(S));
          AncestorClassName := Trim(AncestorClassName);
          C := GetClass(AncestorClassName);
          if C <> nil then
          begin
            C := C.ClassParent;
            AncestorClassName := C.ClassName;
          end
          else
            AncestorClassName := 'TForm';
        end;

        if AncestorClassName = 'TForm' then
          AncestorClassName := ExtractAncestorClassName(src);

        Inc(K);

        if K = 1 then
        begin
          FormName := Copy(S, 1, Pos(':', S) - 1);
          Delete(FormName, 1, 7);
          FormName := TrimLeft(FormName);
          S := TrimLeft(Copy(S, Pos(':', S) + 1, 100));
          ClassName := TrimRight(S);
          Output.Add(Indent + ClassName + ' = class(' + AncestorClassName + ')');
        end
        else
        begin
          Delete(S, 1, 7);
          S := Trim(S);

          if not IsInherited then
            Output.Add(Indent + '  ' + S + ';');
        end;
      end
      else if (StrEql('end ', Copy(S, 1, 4))) and (not OBJECT_SWITCH) then
      begin
        Dec(K);

        if K = 0 then
        begin
          Output.Add(Indent + '  constructor Create(AOwner: TComponent);');
          PosConstructor := Output.Count;
          Output.Add(Indent + 'end;');
        end;
      end;
    end;

    OBJECT_SWITCH := false;

    Output.Add('');
    Output.Add('var');
    Output.Add('  ' + FormName + ': ' + ClassName + ';');

    if AsUnit then
      Output.Add('implementation');

    Output.Add('');
    Output.Add('constructor ' + ClassName + '.Create(AOwner: TComponent);');
    Pos_S := Output.Add('begin');
    Output.Add('  inherited;');

  // constructor's body

    K := 0;
    Indent := '';

//  for I:=0 to InputList.Count - 1 do
    I := -1;
    while I < InputList.Count - 2 do
    begin
      Inc(I);

      S := TrimLeft(InputList[I]) + ' ';

      if StrEql('object ', Copy(S, 1, 7)) or StrEql('inherited ', Copy(S, 1, 10)) then
      begin
        IsInherited := false;
        if Pos('inherited ', S) = 1 then
        begin
          S := StringReplace(S, 'inherited ', 'object ', []);
          IsInherited := true;
        end;

        Inc(K);

        if K = 1 then
        begin
          StackObj[K] := 'Self';
          StackCls[K] := 'TForm';
        end
        else
        begin
          Delete(S, 1, 7);
          S := Trim(S);
          AnObject := Copy(S, 1, Pos(':', S) - 1);
          AClass := TrimLeft(Copy(S, Pos(':', S) + 1, 100));

          if anObject = '' then
            anObject := '_' + AClass;

          if (FindGlobalComponent(AnObject) = nil) and (IsInherited = false) then
            Output.Add(Indent + AnObject + ' := ' + AClass +  '.Create(' + StackObj[K-1] + ');');

          Output.Add(Indent + AnObject + '.Name := ' + AP + AnObject + AP + ';');
          C := GetClass(AClass);
          if Assigned(C) then
          begin
            if _InheritsFrom(C.ClassName, 'TControl') then
              Output.Add(Indent + AnObject + '.Parent := ' + StackObj[K-1] + ';');

            if HasPublishedProperty(C, 'caption', nil) then
              Output.Add(Indent + AnObject + '.Caption := ' + AP + AP + ';');
            if HasPublishedProperty(C, 'text', nil) then
              Output.Add(Indent + AnObject + '.Text := ' + AP + AP + ';');
            if HasPublishedProperty(C, 'lines', nil) then
              Output.Add(Indent + AnObject + '.Lines.Text := ' + AP + AP + ';');

            if _InheritsFrom(C.ClassName, 'TMenuItem') then
            begin
              if StrEql('TMainMenu', StackCls[K-1]) then
                Output.Add(Indent + StackObj[K-1] + '.Items.Add(' + AnObject + ');')
              else if StrEql('TPopUpMenu', StackCls[K-1]) then
                Output.Add(Indent + StackObj[K-1] + '.Items.Add(' + AnObject + ');')
              else
                Output.Add(Indent + StackObj[K-1] + '.Add(' + AnObject + ');');
            end;
          end;

          Output.Add(Indent + 'with ' + AnObject + ' do');

          Output.Add(Indent + 'begin');

          StackObj[K] := AnObject;
          StackCls[K] := AClass;
        end;

        Indent := Indent + '  ';
      end
      else if (StrEql('end ', Copy(S, 1, 4))) and (not OBJECT_SWITCH) then
      begin
        Dec(K);
        Delete(Indent, 1, 2);

        if K > 0 then
          Output.Add(Indent + 'end;');
      end
      else
      begin
        if StrEql('TextHeight ', Copy(S, 1, 11)) then
          continue;
        if StrEql('TextWidth ', Copy(S, 1, 10)) then
          continue;

        S := TrimRight(S);
        S := StringReplace(S, '<>', 'nil', [rfReplaceAll]);

        if      StartBinData(S) then
        begin
          Need_S := true;

          SaveObject := Copy(S, 1, Pos('.', S) - 1);
          Output.Add(Indent + '_S := ');
          continue;
        end
        else if ContinueBinData(S) then
        begin
          Output.Add(Indent + AP + S + AP + '+');
          continue;
        end
        else if EndBinData(S) then
        begin