unit1.pas

Delphi脚本控件

          TypeRes := 'typeDOUBLE';
        end
        else
        begin
          S := '   result.PValue^ := ';
          SignEx := false;
        end;
      end
      else
      begin
        TypeRes := 'typeVARIANT';
        S := '';
      end;

      S := S + CurrentClass + '(Self).';

      S := S + E.Name + '(';
      for I:=1 to P.NP do
      begin
        S := S + 'Params[' + IntToStr(I-1) + '].';

        if I > 1 then types := types + ',';

        if P.Types[I] = P.typCARDINAL then
        begin
          S := S + 'AsCardinal';
          types := types + 'typeCARDINAL';
        end
        else if P.Types[I] = P.typDWORD then
        begin
          S := S + 'AsCardinal';
          types := types + 'typeCARDINAL';
        end
        else if P.Types[I] = P.typUINT then
        begin
          S := S + 'AsCardinal';
          types := types + 'typeCARDINAL';
        end
        else if P.Types[I] = P.typBYTE then
        begin
          S := S + 'AsInteger';
          types := types + 'typeINTEGER';
        end
        else if P.Types[I] = P.typEXTENDED then
        begin
          S := S + 'AsDouble';
          types := types + 'typeDOUBLE';
        end
        else if P.Types[I] = P.typSINGLE then
        begin
          S := S + 'AsDouble';
          types := types + 'typeINTEGER';
        end
        else if P.Types[I] = P.typPOINTER then
        begin
          S := S + 'AsPointer';
          types := types + 'typePOINTER';
        end
        else if P.Types[I] = P.typSTRING then
        begin
          S := S + 'AsString';
          types := types + 'typeSTRING';
        end
        else if P.Types[I] = P.typBOOLEAN then
        begin
          S := S + 'AsBoolean';
          types := types + 'typeBOOLEAN';
        end
        else if P.Types[I] = P.typINTEGER then
        begin
          S := S + 'AsInteger';
          types := types + 'typeINTEGER';
        end
        else if P.Types[I] = P.typDOUBLE then
        begin
          S := S + 'AsDouble';
          types := types + 'typeDOUBLE';
        end
        else
        begin
          S := S + 'PValue^';
          SignEx := false;
        end;

        if I < P.NP then
          S := S + ',';
      end;
      S := S + ');';
      ExtraCode.Add(S);
      ExtraCode.Add('end;');

      if (Types <> '') and (TypeRes <> '') then
        Types := Types + ',';

      if SignEx then
      begin
        if UserData = '' then
          AddLine('RegisterStdMethodEx(' + CurrentClass + ',' +
                 StringConst(E.Name) + ',' +
                 CurrentClass + '_' + FakeName + ',' + IntToStr(P.NP) +
                 ',[' + Types + TypeRes + ']' +
                  ');')
        else
          AddLine('RegisterStdMethodEx(' + CurrentClass + ',' +
                 StringConst(E.Name) + ',' +
                 CurrentClass + '_' + FakeName + ',' + IntToStr(P.NP) +
                 ',[' + Types + TypeRes + ']' + ', ' + UserData +
                  ');')
      end
      else
      begin
        if UserData = '' then
          AddLine('RegisterStdMethod(' + CurrentClass + ',' +
                   StringConst(E.Name) + ',' +
                   CurrentClass + '_' + FakeName + ',' + IntToStr(P.NP) + ');')
        else
          AddLine('RegisterStdMethod(' + CurrentClass + ',' +
                   StringConst(E.Name) + ',' +
                   CurrentClass + '_' + FakeName + ',' + IntToStr(P.NP) + ', ' + UserData + ');')
     end;
    end
    else
    begin
      if body = bInterface then
      begin
//     AddLine('RegisterInterfaceMethod(TypeInfo(' + CurrentClass + '),');

        AddLine('RegisterInterfaceMethod(' + CurrentClass + ',');

        if UserData = '' then
          AddLine(Space(5) + StringConst(E.Declaration) + ');')
        else
          AddLine(Space(5) + StringConst(E.Declaration) + ', -1, ' + UserData + ');')
      end
      else if PosOver > 0 then
      begin
      end
      else
      begin
        AddLine('RegisterMethod(' + CurrentClass + ',');
        AddLine(Space(5) + StringConst(E.Declaration) + ',');

        if UserData = '' then
          AddLine(Space(5) + '@' + CurrentClass + '.' + E.Name + ');')
        else
          AddLine(Space(5) + '@' + CurrentClass + '.' + E.Name + ', false, ' + UserData + ');')
      end;

      if Pos('constructor', E.Declaration) = 1 then
      with VisitedClasses do
        TClassRec(Objects[Count - 1]).ConstructorDef := E.Declaration;
    end;
  finally
    P.Free;
  end;
end;

procedure TForm1.WDelphiParser1EnumType(const TypeName: String);
begin
  if RadioButton1.Checked then
    AddLine('RegisterRTTIType(TypeInfo(' + TypeName + '));');
end;

procedure TForm1.WDelphiParser1ClassPropertyEntry(aEntry: TEntry;
  aAddEntry: Boolean);

var
  E: TClassPropertyEntry;
  ReadProc, WriteProc, Params: String;

function ActualParams: String;
var
  I: Integer;
  ch: Char;
  Skip: Boolean;
begin
  result := '';
  Skip := false;
  for I:=1 to Length(Params) do
  begin
    ch := Params[I];
    case ch of
      ';':
      begin
        result := result + ',';
        Skip := false;
      end;
      ':':
      begin
        Skip := true;
      end;
    else
    if not Skip then
      result := result + ch;
    end;
  end;

  I := Pos('CONST ', UpperCase(result));
  while I > 0 do
  begin
    Delete(result, I, 6);
    I := Pos('CONST ', UpperCase(result));
  end;
end;

{
function AddReadProc: Boolean;
var
  S: String;
begin
  result := true;

  ReadProc := CurrentClass + '_Get' + E.Name;

  if Params = '' then
    S := 'function ' + ReadProc + ':' + E.TypeName + ';'
  else
  begin
    result := Pos(':', Params) > 0;
    S := 'function ' + ReadProc + '(' + Params + '):' + E.TypeName + ';';
  end;

  if not result then
    Exit;

  AddLine('RegisterMethod(' + CurrentClass + ',');
  AddLine(Space(5) + StringConst(S) + ',');
  AddLine(Space(5) + '@' + ReadProc + ', Fake);');

  ExtraCode.Add(S);
  ExtraCode.Add('begin');
  S := 'result := ' + CurrentClass + '(_Self).' + E.Name;
  if Params <> '' then
    S := S + '[' + ActualParams + ']';
  S := S + ';';
  ExtraCode.Add(Space(DeltaMargin) + S);
  ExtraCode.Add('end;');
end;
}

function AddReadProc: Boolean;
var
  S: String;
begin
  result := true;

  ReadProc := CurrentClass + '__Get' + E.Name;

  if Params = '' then
    S := 'function ' + ReadProc + '(Self:' + CurrentClass +  '):' +
          E.TypeName + ';'
  else
  begin
    result := Pos(':', Params) > 0;
    S := 'function ' + ReadProc + '(Self:' + CurrentClass + ';' +
             Params + '):' + E.TypeName + ';';
  end;

  if not result then
    Exit;

  AddLine('RegisterMethod(' + CurrentClass + ',');
  AddLine(Space(5) + StringConst(S) + ',');

  if UserData = '' then
    AddLine(Space(5) + '@' + ReadProc + ', true);')
  else
    AddLine(Space(5) + '@' + ReadProc + ', true, ' + UserData + ');');

  ExtraCode.Add(S);
  ExtraCode.Add('begin');
  S := 'result := Self.' + E.Name;
  if Params <> '' then
    S := S + '[' + ActualParams + ']';
  S := S + ';';
  ExtraCode.Add(Space(DeltaMargin) + S);
  ExtraCode.Add('end;');
end;

{
function AddWriteProc: Boolean;
var
  S: String;
begin
  result := true;

  WriteProc := CurrentClass + '_Put' + E.Name;
  S := 'procedure ' + WriteProc + '(' + Params;
  if Params <> '' then
  begin
    result := Pos(':', Params) > 0;
    S := S + ';';
  end;

  if not result then
    Exit;

  S := S + 'const Value: ' + E.TypeName + ');';

  AddLine('RegisterMethod(' + CurrentClass + ',');
  AddLine(Space(5) + StringConst(S) + ',');
  AddLine(Space(5) + '@' + WriteProc + ', Fake);');

  ExtraCode.Add(S);
  ExtraCode.Add('begin');
  S := CurrentClass + '(_Self).' + E.Name;
  if Params <> '' then
    S := S + '[' + ActualParams + ']';
  S := S + ' := Value;';
  ExtraCode.Add(Space(DeltaMargin) + S);
  ExtraCode.Add('end;');
end;
}

function AddWriteProc: Boolean;
var
  S: String;
begin
  result := true;

  WriteProc := CurrentClass + '__Put' + E.Name;
  S := 'procedure ' + WriteProc + '(Self:' + CurrentClass + ';' + Params;
  if Params <> '' then
  begin
    result := Pos(':', Params) > 0;
    S := S + ';';
  end;

  if not result then
    Exit;

  S := S + 'const Value: ' + E.TypeName + ');';

  AddLine('RegisterMethod(' + CurrentClass + ',');
  AddLine(Space(5) + StringConst(S) + ',');

  if UserData = '' then
    AddLine(Space(5) + '@' + WriteProc + ', true);')
  else
    AddLine(Space(5) + '@' + WriteProc + ', true, ' + UserData + ');');

  ExtraCode.Add(S);
  ExtraCode.Add('begin');
  S := 'Self.' + E.Name;
  if Params <> '' then
    S := S + '[' + ActualParams + ']';
  S := S + ' := Value;';
  ExtraCode.Add(Space(DeltaMargin) + S);
  ExtraCode.Add('end;');
end;

var
  S: String;
  P1, P2: Integer;
  result: Boolean;
begin
  EndOfUsesClause;

  if CurrentClass = '' then
    Exit;

  E := TClassPropertyEntry(aEntry);

  if E.IsEvent then
    Exit;

  if Pos('On', E.Name) = 1 then
    Exit;

  if body = bInterface then
  begin
    if UserData = '' then
      AddLine('RegisterInterfaceProperty(' + CurrentClass + ',' + StringConst(E.Declaration) + ');')
    else
      AddLine('RegisterInterfaceProperty(' + CurrentClass + ',' + StringConst(E.Declaration) + ', ' + UserData + ');');
    Exit;
  end;

  ReadProc := '';
  WriteProc := '';
  Params := '';

  P1 := Pos('[', E.Declaration);
  P2 := Pos(']', E.Declaration);
  if P2 > P1 then
    Params := Copy(E.Declaration, P1 + 1, P2 - P1 - 1);

  result := true;

  if Pos(' read ', E.Declaration) > 0 then
    result := result and AddReadProc;

  if Pos(' write ', E.Declaration) > 0 then
    result := result and AddWriteProc;

  if (ReadProc = '') and (WriteProc = '') then
    Exit;

  if not result then
    Exit;

  AddLine('RegisterProperty(' + CurrentClass + ',');

  S := 'property ' + E.Name;
  if Params <> '' then
    S := S + '[' + Params + ']';
  S := S + ':' + E.TypeName;
  if ReadProc <> '' then
    S := S + ' read ' + ReadProc;
  if WriteProc <> '' then
    S := S + ' write ' + WriteProc;
  S := S + ';';
  if E.ArrayIsDefaultProperty then
    S := S + 'default;';

  if UserData = '' then
    AddLine(Space(5) + StringConst(S) + ');')
  else
    AddLine(Space(5) + StringConst(S) + ', ' + UserData + ');')
end;

procedure TForm1.WDelphiParser1EndOfClassDef(var aStopAnalyze: Boolean);
begin
  EndOfUsesClause;

  if CurrentClass = '' then
    Exit;

  EndOfClass;
  body := bNone;
end;

procedure TForm1.WDelphiParser1EndOfInterfaceDef(var aStopAnalyze: Boolean);
begin
  EndOfUsesClause;

  if CurrentClass = '' then
    Exit;

  EndOfClass;
  body := bNone;
end;

//---------- Initialization ------------------//

procedure TForm1.WDelphiParser1AfterUnitEntry(aFileName: String);
begin
  EndOfUsesClause;

  Blockquote(false);

  if RadioButton1.Checked then
  begin
    AddLine('end;');
    AddLine('initialization');
    AddLine('  Register' + UnitName + ';');
    AddLine('end.');
  end
  else if RadioButton2.Checked then
  begin
    AddLine('end;');
    AddLine('end;');
    AddLine('exports');
    AddLine('  RegisterDllProcs;');
    AddLine('begin');
    AddLine('end.');
  end;
end;

procedure TForm1.ListBox1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  S: String;
begin
  if Key = vk_F1 then
    if ListBox1.ItemIndex >= 0 then
    begin
      S := ListBox1.Items[ListBox1.ItemIndex];
      S