unit1.pas

Delphi脚本控件

    ExtraCode.Add('  TRegClass = class');
    ExtraCode.Add('    procedure  RegColor(const S: string);');
    ExtraCode.Add('  end;');
    ExtraCode.Add('procedure TRegClass.RegColor(const S: string);');
    ExtraCode.Add('var');
    ExtraCode.Add('  C: Integer;');
    ExtraCode.Add('begin');
    ExtraCode.Add('  if IdentToColor(S, C) then');
    ExtraCode.Add('    RegisterConstant(S, C, -1);');
    ExtraCode.Add('end;');
    ExtraCode.Add('procedure RegisterColorValues;');
    ExtraCode.Add('var');
    ExtraCode.Add('  X: TRegClass;');
    ExtraCode.Add('begin');
    ExtraCode.Add('  X := TRegClass.Create;');
    ExtraCode.Add('  GetColorValues(X.RegColor);');
    ExtraCode.Add('  X.Free;');
    ExtraCode.Add('end;');
  end;

  Memo2.Lines.Clear;

  for I:=0 to ExtraCodePoint - 1 do
    Memo2.Lines.Add(L[I]);

  for I:=0 to ExtraCode.Count - 1 do
    Memo2.Lines.Add(ExtraCode[I]);

  for I:=ExtraCodePoint to L.Count - 1 do
    Memo2.Lines.Add(L[I]);

  L.Free;

  Screen.Cursor := crDefault;
  Label2.Caption := IntToStr(ListBox1.Items.Count);
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
  I: Integer;
begin
  UsedUnits.Free;
  for I:=0 to VisitedClasses.Count - 1 do
    VisitedClasses.Objects[I].Free;
  VisitedClasses.Free;
  ExtraCode.Free;
  StandardTypes.Free;
  VisitedRoutines.Free;

  WDelphiParser1.Free;
end;

procedure TForm1.EndOfUsesClause;
var
  B: Boolean;
begin
  if not UsesClauseHasBeenProcessed then
    WDelphiParser1EndOfUsesClause(B);
end;

procedure TForm1.EndOfClass;
var
  C, C1: TClassRec;
  K: Integer;
  Found: Boolean;
begin
  Found := false;
  if CurrentClass <> '' then
  begin
    with VisitedClasses do
      C := TClassRec(Objects[Count - 1]);

    if (C.ConstructorDef = '') and (body <> bInterface) then
    begin
      K := C.E.Parents.Count - 1;
      if StrEql(C.E.Parents[K], 'TObject') or
         StrEql(C.E.Parents[K], 'TPersistent') then
      begin
        Found := true;
        C.ConstructorDef := 'constructor Create;';
      end
      else if StrEql(C.E.Parents[K], 'Exception') then
      begin
        Found := true;
        C.ConstructorDef := 'constructor Create(const Msg: string);';
      end
      else if StrEql(C.E.Parents[K], 'TComponent') or
              StrEql(C.E.Parents[K], 'TForm') then
      begin
        Found := true;
        C.ConstructorDef := 'constructor Create(AOwner: TComponent); virtual;';
      end;

      if not Found then
      begin
        K := VisitedClasses.IndexOf(C.E.Parents[K]);
        if K >= 0 then
        begin
          C1 := TClassRec(VisitedClasses.Objects[K]);
          if C1.ConstructorDef <> '' then
          begin
            Found := true;
            C.ConstructorDef := C1.ConstructorDef;
          end;
        end;
      end;

      if Found then
        Found := ValidConst(C.ConstructorDef);

      if Found then
      begin
        AddLine('RegisterMethod(' + CurrentClass + ',');
        AddLine(Space(5) + StringConst(C.ConstructorDef) + ',');

        if UserData = '' then
          AddLine(Space(5) + '@' + CurrentClass + '.Create);')
        else
          AddLine(Space(5) + '@' + CurrentClass + '.Create, false,' + UserData + ');');
      end
      else
      begin
        AddLine('// CONSTRUCTOR IS NOT FOUND!!!');
        ListBox1.Items.Add(CurrentClass + ': constructor is not found!');
      end;
    end;

    if body = bInterface then
      AddLine('// End of interface ' + CurrentClass)
    else
      AddLine('// End of class ' + CurrentClass);

    CurrentClass := '';
  end;
end;

//--------- Uses Clause -------------------//

procedure TForm1.WDelphiParser1UsedUnit(aFileName: String);
begin
  UsedUnits.Add(aFileName);
end;

procedure TForm1.WDelphiParser1EndOfUsesClause(var aStopAnalyze: Boolean);
var
  I: Integer;
  S: String;
begin
  S := Copy(UnitName, 5, 100);
  if UsedUnits.IndexOf(S) = -1 then
    UsedUnits.Add(S);

  if RadioButton1.Checked then
  begin
    if UsedUnits.IndexOf('VARIANTS') = -1 then
      UsedUnits.Add('Variants');
    if UsedUnits.IndexOf('BASE_SYS') = -1 then
      UsedUnits.Add('BASE_SYS');
    if UsedUnits.IndexOf('BASE_EXTERN') = -1 then
      UsedUnits.Add('BASE_EXTERN');
    if UsedUnits.IndexOf('PaxScripter') = -1 then
      UsedUnits.Add('PaxScripter');

    AddLine('uses');
  end
  else if RadioButton2.Checked then
  begin
    if UsedUnits.IndexOf('PaxImport') = -1 then
      UsedUnits.Add('PaxImport');
    AddLine('uses');
  end;

  Blockquote(true);
  for I:=0 to UsedUnits.Count - 1 do
  begin
    S := UsedUnits[I];
    if I = UsedUnits.Count - 1 then
      S := S + ';'
    else
      S := S + ',';
    AddLine(S);
  end;
  Blockquote(false);

  if RadioButton1.Checked then
  begin
    AddLine('procedure Register' + UnitName + ';');
    AddLine('implementation');

    ExtraCodePoint := Memo2.Lines.Count;

    AddLine('procedure Register' + UnitName + ';');
    AddLine('var H: Integer;');
    AddLine('begin');
    Blockquote(true);
  end
  else if RadioButton2.Checked then
  begin
    ExtraCodePoint := Memo2.Lines.Count;
    AddLine('procedure RegisterDllProcs(PaxRegisterProcs: TPaxRegisterProcs);');
    AddLine('var H: Integer;');
    AddLine('begin');
    AddLine('with PaxRegisterProcs do begin');
    Blockquote(true);
  end;

  S := Copy(UnitName, 5, 100);

  AddLine('H := RegisterNamespace(' + StringConst(S) + ', -1);');

  if StrEql(S, 'Graphics') then
    AddLine('RegisterColorValues;');

  UsesClauseHasBeenProcessed := true;
end;

//--------- Const Section -------------------//

procedure TForm1.WDelphiParser1ConstEntry(aEntry: TEntry;
  aAddEntry: Boolean);
const
  MAX_VALUE:extended=1.7E307;
  MIN_VALUE:extended=4.0E-324;
var
  E: TConstantEntry;
  I64: Int64;
  D: Extended;
  S: String;
  P: Integer;
begin
  EndOfUsesClause;

  E := TConstantEntry(aEntry);

  P := Pos('=', E.Declaration);
  if P > 0 then
  begin
    S := Trim(Copy(E.Declaration, 1, P - 1));
  end
  else
  begin
    S := E.Name;
  end;

  if IsIntegerConst(E.Value) or IsHexConst(E.Value) then
  begin
    I64 := StrToInt64(E.Value);
    if Abs(I64) > MaxInt then
    begin
      if UserData = '' then
        AddLine('RegisterInt64Constant(' + StringConst(S) + ', ' + E.Value + ', H);')
      else
        AddLine('RegisterInt64Constant(' + StringConst(S) + ', ' + E.Value + ', H, ' + UserData + ');');
    end
    else
    begin
      if UserData = '' then
        AddLine('RegisterConstant(' + StringConst(S) + ', ' + E.Value + ', H);')
      else
        AddLine('RegisterConstant(' + StringConst(S) + ', ' + E.Value + ', H, ' + UserData + ');');
    end;
  end
  else if IsRealConst(E.Value) then
  begin
    D := StrToFloatDef(E.Value, 0);
    if (D < MAX_VALUE) and (D > MIN_VALUE) then
    begin
      if UserData = '' then
        AddLine('RegisterConstant(' + StringConst(S) + ', ' + E.Value + ', H);')
      else
        AddLine('RegisterConstant(' + StringConst(S) + ', ' + E.Value + ', H, ' + UserData + ');');
    end;
  end
  else if IsStringConst(E.Value) then
  begin
    if UserData = '' then
      AddLine('RegisterConstant(' + StringConst(S) + ', ' + E.Value + ', H);')
    else
      AddLine('RegisterConstant(' + StringConst(S) + ', ' + E.Value + ', H, ' + UserData + ');');
  end;
end;

//--------- Variable Section -------------------//

procedure TForm1.WDelphiParser1VarEntry(aEntry: TEntry;
  aAddEntry: Boolean);
var
  E: TVariableEntry;
  UpTypeName: String;
begin
  EndOfUsesClause;

  E := TVariableEntry(aEntry);

  UpTypeName := UpperCase(E.TypeName);
  if StandardTypes.IndexOf(UpTypeName) > 0 then
  begin
    if UpTypeName = 'LONGINT' then
      UpTypeName := 'INTEGER'
    else if UpTypeName = 'LONGWORD' then
      UpTypeName := 'CARDINAL'
    else if UpTypeName = 'DWORD' then
      UpTypeName := 'CARDINAL'
    else if UpTypeName = 'UINT' then
      UpTypeName := 'CARDINAL'
    else if UpTypeName = 'ULONG' then
      UpTypeName := 'CARDINAL'
    else if UpTypeName = 'THANDLE' then
      UpTypeName := 'CARDINAL';

    if UserData = '' then
      AddLine('RegisterVariable(' + StringConst(E.Name) + ', ' +
                                  StringConst(UpTypeName) + ',' +
                                  '@' + E.Name + ', H);')
    else
      AddLine('RegisterVariable(' + StringConst(E.Name) + ', ' +
                                  StringConst(UpTypeName) + ',' +
                                  '@' + E.Name + ', H, ' + UserData + ');');
  end;
end;

//--------- Interface  -------------------//

procedure TForm1.WDelphiParser1InterfaceEntry(aEntry: TEntry;
  aAddEntry, IsForward: Boolean);
var
  E: TInterfaceEntry;
begin
  EndOfUsesClause;

  E := TInterfaceEntry(aEntry);

  if E.IsMetaClass then
    Exit;
  if IsForward then
    Exit;
  if E.Parents.Count = 0 then
    Exit;

  if E.GUID = '' then
  begin
    CurrentClass := '';
    Exit;
  end;

  CurrentClass := E.Name;

  VisitedClasses.AddObject(CurrentClass, TClassRec.Create(E));

  AddLine('// Begin of interface ' + CurrentClass);
//  AddLine('RegisterRTTIType(TypeInfo(' + CurrentClass + '), H);');


  if UserData = '' then
    AddLine('RegisterInterfaceType(' + StringConst(E.Name) + ',' +
                                    E.Name + ',' +
                                    StringConst(E.Parents[0]) + ',' +
                                    E.Parents[0] + ',' +
                                    'H);')
  else
    AddLine('RegisterInterfaceType(' + StringConst(E.Name) + ',' +
                                    E.Name + ',' +
                                    StringConst(E.Parents[0]) + ',' +
                                    E.Parents[0] +
                                    ', H, ' + UserData + ');');
  body := bInterface;
end;

procedure TForm1.WDelphiParser1DispInterfaceEntry(aEntry: TEntry;
  aAddEntry, IsForward: Boolean);
var
  E: TInterfaceEntry;
begin
  EndOfUsesClause;

  E := TInterfaceEntry(aEntry);

  if E.IsMetaClass then
    Exit;
  if IsForward then
    Exit;

  if E.GUID = '' then
  begin
    CurrentClass := '';
    Exit;
  end;

  CurrentClass := E.Name;

  VisitedClasses.AddObject(CurrentClass, TClassRec.Create(E));

  Exit; // not implemented yet

  AddLine('// Begin of interface ' + CurrentClass);
//  AddLine('RegisterRTTIType(TypeInfo(' + CurrentClass + '), H);');


  if UserData = '' then
      AddLine('RegisterInterfaceType(' + StringConst(E.Name) + ',' +
                                    E.Name + ',' +
                                    StringConst('IDispatch') + ',' +
                                    'IDispatch' + ',' +
                                    'H);')
  else
      AddLine('RegisterInterfaceType(' + StringConst(E.Name) + ',' +
                                    E.Name + ',' +
                                    StringConst('IDispatch') + ',' +
                                    'IDispatch' +
                                    ', H, ' + UserData + ');');

  body := bInterface;
end;

//--------- Type  -------------------//

procedure TForm1.WDelphiParser1TypeEntry(aEntry: TEntry; aAddEntry : boolean);
var
  E: TTypeEntry;
begin
  EndOfUsesClause;

  E := TTypeEntry(aEntry);

  if Pos('^', E.ExistingType) > 0 then
    Exit;
  if Pos('[', E.ExistingType) > 0 then
    Exit;
  if Pos(' of ', E.ExistingType) > 0 then
  begin
    if Pos('SET ', UpperCase(E.ExistingType)) = 1 then
      AddLine('RegisterRTTIType(TypeInfo(' + E.Name + '));');
    Exit;
  end;
  if Pos('(', E.ExistingType) > 0 then
    Exit;

  if Pos('..', E.ExistingType) > 0 then
    AddLine('RegisterRTTIType(TypeInfo(' + E.Name + '));')
  else
    AddLine('RegisterTypeAlias(' + StringConst(E.Name) + ',' + StringConst(E.ExistingType) + ');');
end;

//--------- Class  -------------------//

procedure TForm1.WDelphiParser1ClassEntry(aEntry: TEntry;  aAddEntry, IsForward: Boolean);
var
  E: TClassEntry;
begin
  EndOfUsesClause;

  E := TClassEntry(aEntry);

  if E.IsMetaClass then
    Exit;
  if IsForward then
    Exit;

  CurrentClass := E.Name;

  VisitedClasses.AddObject(CurrentClass, TClassRec.Create(E));

  AddLine('// Begin of class ' + CurrentClass);

  if UserData = '' then
    AddLine('RegisterClassType(' + CurrentClass + ', H);')
  else
    AddLine('RegisterClassType(' + CurrentClass + ', H, ' + UserData + ');');

  body := bClass;
end;

//--------- Global procedure -------------------//

procedure TForm1.WDelphiParser1ProcedureEntry(aEntry: TEntry;
  aAddEntry: Boolean);
var
  E: TProcedureEntry;
  P: TSimpleParser;