unit1.pas

Delphi脚本控件

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  uWDelphiParser, StdCtrls, Buttons, ExtCtrls, ComCtrls, Unit2;

const
  DeltaMargin = 2;

type
  TClassRec = class
    E: TClassEntry;
    ConstructorDef: String;
    constructor Create(E: TClassEntry);
  end;

  TBody = (bNone, bClass, bInterface);

  TForm1 = class(TForm)
    Panel1: TPanel;
    Panel3: TPanel;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    SpeedButton3: TSpeedButton;
    Memo1: TRichEdit;
    Memo2: TRichEdit;
    Panel2: TPanel;
    Label1: TLabel;
    ListBox1: TListBox;
    Label2: TLabel;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure WDelphiParser1UsedUnit(aFileName: String);
    procedure WDelphiParser1EndOfUsesClause(var aStopAnalyze: Boolean);
    procedure WDelphiParser1ConstEntry(aEntry: TEntry; aAddEntry: Boolean);
    procedure WDelphiParser1VarEntry(aEntry: TEntry; aAddEntry: Boolean);
    procedure WDelphiParser1AfterUnitEntry(aFileName: String);
    procedure WDelphiParser1TypeEntry(aEntry: TEntry; aAddEntry : boolean);
    procedure WDelphiParser1ClassEntry(aEntry: TEntry;  aAddEntry, IsForward: Boolean);
    procedure WDelphiParser1InterfaceEntry(aEntry: TEntry;
                                           aAddEntry, IsForward: Boolean);
    procedure WDelphiParser1DispInterfaceEntry(aEntry: TEntry;
                                           aAddEntry, IsForward: Boolean);
    procedure WDelphiParser1ClassFunctionEntry(aEntry: TEntry;
      aAddEntry: Boolean);
    procedure WDelphiParser1FunctionEntry(aEntry: TEntry;
      aAddEntry: Boolean);
    procedure WDelphiParser1ProcedureEntry(aEntry: TEntry;
      aAddEntry: Boolean);
    procedure WDelphiParser1ClassProcedureEntry(aEntry: TEntry;
      aAddEntry: Boolean);
    procedure SpeedButton3Click(Sender: TObject);
    procedure WDelphiParser1EndOfClassDef(var aStopAnalyze: Boolean);
    procedure WDelphiParser1EndOfInterfaceDef(var aStopAnalyze: Boolean);
    procedure WDelphiParser1ClassPropertyEntry(aEntry: TEntry;
      aAddEntry: Boolean);
    procedure WDelphiParser1EnumType(const TypeName: String);
    procedure ListBox1KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ListBox1DblClick(Sender: TObject);
  private
    { Private declarations }
    UnitName: String;
    SourceUnitName: String;
    UsedUnits, VisitedClasses, VisitedRoutines,
    ExtraCode: TStringList;
    StandardTypes: TStringList;
    Margin, ExtraCodePoint: Integer;
    CurrentClass: String;
    UsesClauseHasBeenProcessed: Boolean;
    WDelphiParser1: TWDelphiParser;

    UserData: String;

    OverCount: Integer;
    body: TBody;
  public
    procedure AddLine(const S: String = '');
    procedure Blockquote(Value: Boolean);
    procedure EndOfClass;
    procedure EndOfUsesClause;
    function IsValidProcedureEntry(E: TProcedureEntry): Boolean;
    function IsValidFunctionEntry(E: TFunctionEntry): Boolean;
    function IsValidClassProcedureEntry(E: TClassProcedureEntry): Boolean;
    function IsValidClassFunctionEntry(E: TClassFunctionEntry): Boolean;
    { Public declarations }
  end;


function Space(L: Integer): String;

var
  Form1: TForm1;

const
  AP = '''';
var
  Z: Integer;

implementation

{$R *.DFM}

function StrEql(Const S1, S2: String): Boolean;
begin
  Result := CompareText(S1, S2) = 0;
end;

function IsStringConst(const S: String): Boolean;
var
  I: Integer;
begin
  if Length(S) < 2 then
  begin
    result := false;
    Exit;
  end;

  result := (S[1] = AP) and (S[Length(S)] = AP);
end;

function IsIntegerConst(const S: String): Boolean;
var
  I: Integer;
begin
  if S = '' then
  begin
    result := false;
    Exit;
  end;

  result := true;
  for I:=1 to Length(S) do
    if not (S[I] in ['0'..'9']) then
    begin
      result := false;
      Exit;
    end;
end;

function IsHexConst(const S: String): Boolean;
var
  I: Integer;
begin
  if Length(S) < 2 then
  begin
    result := false;
    Exit;
  end;
  if S[1] <> '$' then
  begin
    result := false;
    Exit;
  end;

  result := true;
  for I:=2 to Length(S) do
    if not (S[I] in ['0'..'9','A'..'F']) then
    begin
      result := false;
      Exit;
    end;
end;

function IsRealConst(const S: String): Boolean;
var
  I: Integer;
begin
  if S = '' then
  begin
    result := false;
    Exit;
  end;

  if Pos('.', S) = 0 then
  begin
    result := false;
    Exit;
  end;

  result := true;
  for I:=1 to Length(S) do
    if not (S[I] in ['0'..'9','.','-','+','e','E']) then
    begin
      result := false;
      Exit;
    end;
end;

constructor TClassRec.Create(E: TClassEntry);
begin
  Self.E := E;
  ConstructorDef := '';
end;

function Space(L: Integer): String;
var
  I: Integer;
begin
  result := '';
  for I:=1 to L do
    result := result + ' ';
end;

function StringConst(const S: String): String;
const
  AP: Char = '''';
  MaxSize = 250;
var
  I: Integer;
begin
  result := AP;
  for I:=1 to Length(S) do
    case S[I] of
      '''': result := result + AP + AP;
      #13: begin end;
      #10: begin end;
    else
      result := result + S[I];
    end;
  result := result + AP;

  if Length(result) > MaxSize then
  begin
     result := Copy(result, 1, MaxSize) + AP + '+' + AP + Copy(result, MaxSize + 1, Length(result));
  end;
end;

function ValidConst(const S: String): Boolean;
begin
  result := Pos('{', S) = 0;
end;

function RemoveSpaces(const S: String): String;
var
  I: Integer;
begin
  result := '';
  for I:=1 to Length(S) do
    if S[I] <> ' ' then
      result := result + S[I];
end;

function TForm1.IsValidProcedureEntry(E: TProcedureEntry): Boolean;
var
  S: String;
begin
  result := true;
  if Pos('=', E.Declaration) > 0 then
  begin
    S := RemoveSpaces(E.Declaration);
    if Pos('=(', S) > 0 then
      result := false
    else if Pos('..', S) > 0 then
      result := false
    else
      result := true;
  end;
  if Pos('_', E.Name) = 1 then
    result := false;
end;

function TForm1.IsValidFunctionEntry(E: TFunctionEntry): Boolean;
begin
  result := IsValidProcedureEntry(E);
end;

function TForm1.IsValidClassProcedureEntry(E: TClassProcedureEntry): Boolean;
var
  S: String;
begin
  result := true;
//  if Pos('=', E.Declaration) > 0 then
//    result := false;

  if Pos('=', E.Declaration) > 0 then
  begin
    S := RemoveSpaces(E.Declaration);
    if Pos('=(', S) > 0 then
      result := false
    else if Pos('..', S) > 0 then
      result := false
    else
      result := true;
  end;

  if Pos('_', E.Name) = 1 then
    result := false;

  if rdAbstract in E.RoutineDirectives then
    result := false;
  if rdMessageHandler in E.RoutineDirectives then
    result := false;
end;

function TForm1.IsValidClassFunctionEntry(E: TClassFunctionEntry): Boolean;
begin
  result := IsValidClassProcedureEntry(E);
end;

procedure TForm1.AddLine(const S: String = '');
begin
  Memo2.Lines.Add(Space(Margin) + S);
end;

procedure TForm1.Blockquote(Value: Boolean);
begin
  if Value then
    Inc(Margin, DeltaMargin)
  else
    Dec(Margin, DeltaMargin);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  S: String;
begin
  UserData := '';
  if ParamCount > 0 then
  begin
    UserData := ParamStr(1);
  end;

  WDelphiParser1 := TWDelphiParser.Create(Self);

  WDelphiParser1.MemberVisibility := [vaPublic];

  WDelphiParser1.OnUsedUnit := WDelphiParser1UsedUnit;
  WDelphiParser1.OnEndOfUsesClause := WDelphiParser1EndOfUsesClause;
  WDelphiParser1.OnConstEntry := WDelphiParser1ConstEntry;
  WDelphiParser1.OnVarEntry := WDelphiParser1VarEntry;
  WDelphiParser1.AfterUnitEntry := WDelphiParser1AfterUnitEntry;
  WDelphiParser1.OnTypeEntry := WDelphiParser1TypeEntry;
  WDelphiParser1.OnClassEntry := WDelphiParser1ClassEntry;
  WDelphiParser1.OnInterfaceEntry := WDelphiParser1InterfaceEntry;
  WDelphiParser1.OnDispInterfaceEntry := WDelphiParser1DispInterfaceEntry;
  WDelphiParser1.OnClassFunctionEntry := WDelphiParser1ClassFunctionEntry;
  WDelphiParser1.OnFunctionEntry := WDelphiParser1FunctionEntry;
  WDelphiParser1.OnProcedureEntry := WDelphiParser1ProcedureEntry;
  WDelphiParser1.OnClassProcedureEntry := WDelphiParser1ClassProcedureEntry;
  WDelphiParser1.OnEndOfClassDef := WDelphiParser1EndOfClassDef;
  WDelphiParser1.OnEndOfInterfaceDef := WDelphiParser1EndOfInterfaceDef;
  WDelphiParser1.OnClassPropertyEntry := WDelphiParser1ClassPropertyEntry;
  WDelphiParser1.OnEnumType := WDelphiParser1EnumType;

  body := bNone;

  UnitName := '';
  SourceUnitName := '';
  UsedUnits := TStringList.Create;
  VisitedClasses := TStringList.Create;
  VisitedRoutines := TStringList.Create;
  ExtraCode := TStringList.Create;
  StandardTypes := TStringList.Create;
  with StandardTypes do
  begin
    Add('LONGINT');
    Add('LONGWORD');
    Add('DWORD');
    Add('UINT');
    Add('ULONG');
    Add('THANDLE');

    Add('INTEGER');
    Add('BYTE');
    Add('SHORTINT');
    Add('SMALLINT');
    Add('WORD');
    Add('CARDINAL');
    Add('INT64');
    Add('SINGLE');
    Add('DOUBLE');
    Add('STRING');
    Add('CHAR');
  end;

  S := ExtractFileDir(Application.ExeName);
  SetCurrentDir(S);

  OpenDialog1.InitialDir := S;
  SaveDialog1.InitialDir := S;
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  with OpenDialog1 do
  begin
    Filter := 'Delphi unit (*' + '.pas)' + '|*' + '.pas';
    if Execute then
    begin
      if Pos('.', FileName) = 0 then
        FileName := FileName + '.pas';
      Memo1.Lines.LoadFromFile(FileName);

      WDelphiParser1.FileName := FileName;

      UnitName := ExtractFileName(FileName);
      SourceUnitName := Copy(UnitName, 1, Pos('.', UnitName) - 1);

      UnitName := 'IMP_' + Copy(UnitName, 1, Pos('.', UnitName) - 1);
    end;
  end;
end;

procedure TForm1.SpeedButton3Click(Sender: TObject);
begin
  with SaveDialog1 do
  begin
    if RadioButton1.Checked then
    begin
      Filter := 'Delphi unit (*' + '.pas)' + '|*' + '.pas';
      FileName := UnitName + '.pas';
    end
    else if RadioButton2.Checked then
    begin
      Filter := 'Delphi dll project (*' + '.dpr)' + '|*' + '.dpr';
      FileName := UnitName + '.dpr';
    end;
    if Execute then
    begin
      Memo2.Lines.SaveToFile(FileName);
    end;
  end;
end;

procedure TForm1.SpeedButton2Click(Sender: TObject);
var
  I: Integer;
  L: TStringList;
  T: TextFile;
  S: String;
begin
  body := bNone;

  Screen.Cursor := crHourGlass;
  ListBox1.Items.Clear;
  Label2.Caption := '0';

  Margin := 0;
  UsedUnits.Clear;
  VisitedClasses.Clear;
  VisitedRoutines.Clear;
  ExtraCode.Clear;
  Memo2.Lines.Clear;
  CurrentClass := '';
  UsesClauseHasBeenProcessed := false;
  OverCount := 0;

  if RadioButton1.Checked then
  begin
    AddLine('unit ' + UnitName + ';');
    AddLine('interface');
  end
  else if RadioButton2.Checked then
  begin
    AddLine('library ' + UnitName + ';');
  end;

  WDelphiParser1.Reset;
  WDelphiParser1.Analyze;

  L := TStringList.Create;
  Memo2.Lines.SaveToFile('t.txt');
  L.LoadFromFile('t.txt');
  AssignFile(T, 't.txt');
  Erase(T);

  S := Copy(UnitName, 5, 100);
  if StrEql(S, 'Graphics') then
  begin
    ExtraCode.Add('type');