unit1.pas

Delphi脚本控件

  S, TypeRes, Types, FakeName: String;
  I: Integer;
  SignEx: Boolean;
  PosOver: Integer;
begin
  EndOfUsesClause;

  E := TProcedureEntry(aEntry);

  if not IsValidProcedureEntry(E) then
    Exit;

  if VisitedRoutines.IndexOf(E.Name) >= 0 then
    Exit;

  if ValidConst(E.Declaration) then
  begin
    PosOver := Pos('OVERLOAD', UpperCase(E.Declaration));

    if PosOver > 0 then
    begin
      Inc(OverCount);
      FakeName := E.Name + IntToStr(OverCount);
    end
    else
      FakeName := E.Name;

    P := TSimpleParser.Create;
    try
      P.Parse_Header(E.Declaration);

      if RadioButton2.Checked then
        P.Fail := true;

      if not P.Fail then
      begin
        ExtraCode.Add('procedure _' + FakeName + '(MethodBody: TPAXMethodBody);');
        ExtraCode.Add('begin');
        ExtraCode.Add('  with MethodBody do');

        TypeRes := 'typeINTEGER';
        Types := '';
        SignEx := true;

        S := '';

        S := S + SourceUnitName + '.' + 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('RegisterStdRoutineEx(' +
                   StringConst(E.Name) + ', _' + FakeName + ',' + IntToStr(P.NP) +
                   ',[' + Types + TypeRes + ']' +
                   ', H);')
           else
             AddLine('RegisterStdRoutineEx(' +
                   StringConst(E.Name) + ', _' + FakeName + ',' + IntToStr(P.NP) +
                   ',[' + Types + TypeRes + ']' +
                   ', H, ' + UserData + ');');
        end
        else
        begin
          if UserData = '' then
            AddLine('RegisterStdRoutine(' +
                   StringConst(E.Name) + ', _' + FakeName + ',' + IntToStr(P.NP) +
                   ', H);')
          else
            AddLine('RegisterStdRoutine(' +
                   StringConst(E.Name) + ', _' + FakeName + ',' + IntToStr(P.NP) +
                   ', H, ' + UserData + ');');
        end;
      end
      else
      begin

        if PosOver > 0 then
        begin
          S := Copy(E.Declaration, 1, PosOver - 1);
          S := StringReplace(S, E.Name, FakeName, [rfIgnoreCase]);

          ExtraCode.Add(S);
          ExtraCode.Add('begin');
          S := '  ' + SourceUnitName + '.' + E.Name + '(';
          for I:=0 to P.ParamList.Count - 1 do
          begin
            S := S + P.ParamList[I];
            if I < P.ParamList.Count - 1 then
              S := S + ',';
          end;
          S := S + ');';
          ExtraCode.Add(S);
          ExtraCode.Add('end;');

          if UserData = '' then
            AddLine('RegisterRoutine(' +
                   StringConst(E.Declaration) + ', @' + FakeName + ', H);')
          else
            AddLine('RegisterRoutine(' +
                   StringConst(E.Declaration) + ', @' + FakeName +
                   ', H, ' + UserData + ');');
        end
        else
        begin
          if UserData = '' then
            AddLine('RegisterRoutine(' +
                   StringConst(E.Declaration) + ', @' + E.Name + ', H);')
          else
            AddLine('RegisterRoutine(' +
                   StringConst(E.Declaration) + ', @' + E.Name +
                   ', H, ' + UserData + ');');
        end;
      end;
    finally
      P.Free;
      VisitedRoutines.Add(FakeName);
    end;
  end;
end;

//--------- Global function -------------------//

procedure TForm1.WDelphiParser1FunctionEntry(aEntry: TEntry;
  aAddEntry: Boolean);
var
  E: TFunctionEntry;
  P: TSimpleParser;
  S, TypeRes, Types, FakeName: String;
  I: Integer;
  SignEx: Boolean;
  PosOver: Integer;
begin
  EndOfUsesClause;

  E := TFunctionEntry(aEntry);

  if not IsValidFunctionEntry(E) then
    Exit;

  if VisitedRoutines.IndexOf(E.Name) >= 0 then
    Exit;

  if StrEql(SourceUnitName, 'SysUtils') and StrEql(E.Name, 'StringReplace') then
  begin
    if UserData = '' then
    begin
      AddLine('RegisterConstant(''rfReplaceAll'', rfReplaceAll, H);');
      AddLine('RegisterConstant(''rfIgnoreCase'', rfIgnoreCase, H);');
      AddLine('RegisterStdRoutine(''StringReplace'', _StringReplace, 4, H);');
    end
    else
    begin
      AddLine('RegisterConstant(''rfReplaceAll'', rfReplaceAll, H, ' + UserData + ');');
      AddLine('RegisterConstant(''rfIgnoreCase'', rfIgnoreCase, H, ' + UserData + ');');
      AddLine('RegisterStdRoutine(''StringReplace'', _StringReplace, 4, H, ' + UserData + ');');
    end;

    ExtraCode.Add('procedure _StringReplace(MethodBody: TPAXMethodBody);');
    ExtraCode.Add('var');
    ExtraCode.Add('  Flags: TReplaceFlags;');
    ExtraCode.Add('begin');
    ExtraCode.Add('  with MethodBody do');
    ExtraCode.Add('  begin');
    ExtraCode.Add('    Flags := [];');
    ExtraCode.Add('    result.AsString := StringReplace(Params[0].AsString, Params[1].AsString, Params[2].AsString, Flags);');
    ExtraCode.Add('  end;');
    ExtraCode.Add('end;');
    Exit;
  end
  else if StrEql(SourceUnitName, 'SysUtils') and StrEql(E.Name, 'FileRead') then
  begin
    if UserData = '' then
      AddLine('RegisterStdRoutine(''FileRead'', _FileRead, 3, H);')
    else
      AddLine('RegisterStdRoutine(''FileRead'', _FileRead, 3, H, ' + UserData + ');');

    ExtraCode.Add('procedure _FileRead(MethodBody: TPAXMethodBody);');
    ExtraCode.Add('var');
    ExtraCode.Add('  Count, VT: Integer; V: Variant; S: String; P: Pointer;');
    ExtraCode.Add('begin');
    ExtraCode.Add('  with MethodBody do');
    ExtraCode.Add('  begin');
    ExtraCode.Add('    V := Params[1].AsVariant;');
    ExtraCode.Add('    P := Pointer(Integer(@V) + 8);');
    ExtraCode.Add('    Count := Params[2].AsVariant;');
    ExtraCode.Add('    VT := VarType(V);');
    ExtraCode.Add('    case VT of');
    ExtraCode.Add('      varString:');
    ExtraCode.Add('      begin');
    ExtraCode.Add('        P := AllocMem(Count + 1);');
    ExtraCode.Add('        FillChar(P^, Count + 1, 0);');
    ExtraCode.Add('        try');
    ExtraCode.Add('          Result.AsInteger := FileRead(Params[0].AsVariant, P^, Count);');
    ExtraCode.Add('        finally');
    ExtraCode.Add('          S := String(Pchar(P));');
    ExtraCode.Add('          FreeMem(P, Count + 1);');
    ExtraCode.Add('        end;');
    ExtraCode.Add('        Params[1].AsVariant := S;');
    ExtraCode.Add('      end;');
    ExtraCode.Add('      varVariant:');
    ExtraCode.Add('      begin');
    ExtraCode.Add('        Result.AsInteger := FileRead(Params[0].AsVariant, V, Count);');
    ExtraCode.Add('        Params[1].AsVariant := V;');
    ExtraCode.Add('      end;');
    ExtraCode.Add('      else');
    ExtraCode.Add('      begin');
    ExtraCode.Add('        Result.AsInteger := FileRead(Params[0].AsVariant, P^, Count);');
    ExtraCode.Add('        Params[1].AsVariant := V;');
    ExtraCode.Add('      end;');
    ExtraCode.Add('    end;');
    ExtraCode.Add('  end;');
    ExtraCode.Add('end;');

    Exit;
  end
  else if StrEql(SourceUnitName, 'SysUtils') and StrEql(E.Name, 'FileWrite') then
  begin
    if UserData = '' then
      AddLine('RegisterStdRoutine(''FileWrite'', _FileWrite, 3, H);')
    else
      AddLine('RegisterStdRoutine(''FileWrite'', _FileWrite, 3, H, ' + UserData + ');');

    ExtraCode.Add('procedure _FileWrite(MethodBody: TPAXMethodBody);');
    ExtraCode.Add('var');
    ExtraCode.Add('  Count, VT: Integer;  V: Variant;  I: Integer;  D: Double;  B: Boolean;  S: String;');
    ExtraCode.Add('begin');
    ExtraCode.Add('  with MethodBody do');
    ExtraCode.Add('  begin');
    ExtraCode.Add('    V := Params[1].AsVariant;');
    ExtraCode.Add('    Count := Params[2].AsVariant;');
    ExtraCode.Add('    VT := VarType(V);');
    ExtraCode.Add('    case VT of');
    ExtraCode.Add('      varInteger:');
    ExtraCode.Add('      begin');
    ExtraCode.Add('        I := V;');
    ExtraCode.Add('        Result.AsInteger := FileWrite(Params[0].AsVariant, I, Count);');
    ExtraCode.Add('      end;');
    ExtraCode.Add('      varDouble:');
    ExtraCode.Add('      begin');
    ExtraCode.Add('        D := V;');
    ExtraCode.Add('        Result.AsInteger := FileWrite(Params[0].AsVariant, D, Count);');
    ExtraCode.Add('      end;');
    ExtraCode.Add('      varBoolean:');
    ExtraCode.Add('      begin');
    ExtraCode.Add('        B := V;');
    ExtraCode.Add('        Result.AsInteger := FileWrite(Params[0].AsVariant, B, Count);');
    ExtraCode.Add('      end;');
    ExtraCode.Add('      varString:');
    ExtraCode.Add('      begin');
    ExtraCode.Add('        S := V;');
    ExtraCode.Add('        Result.AsInteger := FileWrite(Params[0].AsVariant, Pointer(S)^, Count);');
    ExtraCode.Add('      end;');
    ExtraCode.Add('      varVariant:');
    ExtraCode.Add('        Result.AsInteger := FileWrite(Params[0].AsVariant, V, Count);');
    ExtraCode.Add('    end;');
    ExtraCode.Add('  end;');
    ExtraCode.Add('end;');

    Exit;
  end;


  if ValidConst(E.Declaration) then
  begin
    PosOver := Pos('OVERLOAD', UpperCase(E.Declaration));

    if PosOver > 0 then
    begin
      Inc(OverCount);
      FakeName := E.Name + IntToStr(OverCount);
    end
    else
      FakeName := E.Name;

    P := TSimpleParser.Create;
    try
      P.Parse_Header(E.Declaration);

      if RadioButton2.Checked then
        P.Fail := true;

      if not P.Fail then
      begin
        ExtraCode.Add('procedure _' + FakeName + '(MethodBody: TPAXMethodBody);');
        ExtraCode.Add('begin');
        ExtraCode.Add('  with MethodBody do');

        TypeRes := '';
        Types := '';
        SignEx := true;

        if P.IsFunction then
        begin
          if P.TypeRes = P.typCARDINAL then
          begin
            S := '   result.AsCardinal := ';
            TypeRes := 'typeCARDINAL';
          end
          else if P.TypeRes = P.typDWORD then
          begin
            S := '   result.AsCardinal := ';
            TypeRes := 'typeCARDINAL';
          end
          else if P.TypeRes = P.typUINT then
          begin
            S := '   result.AsCardinal := ';
            TypeRes := 'typeCARDINAL';
          end
          else if P.TypeRes = P.typBYTE then
          begin
            S := '   result.AsInteger := ';
            TypeRes := 'typeINTEGER';
          end
          else if P.TypeRes = P.typEXTENDED then
          begin
            S := '   result.AsDouble := ';
            TypeRes := 'typeDOUBLE';
          end
          else if P.TypeRes = P.typSINGLE then
          begin
            S := '   result.AsDouble := ';
            TypeRes := 'typeDOUBLE';
          end
          else if P.TypeRes = P.typPOINTER then
          begin
            S := '   result.AsPOINTER := ';
            TypeRes := 'typePOINTER';
          end
          else if P.TypeRes = P.typSTRING then
          begin
            S := '   result.AsString := ';
            TypeRes := 'typeSTRING';
          end
          else if P.TypeRes = P.typBOOLEAN then
          begin
            S := '   result.AsBoolean := ';
            TypeRes := 'typeBOOLEAN';
          end
          else if P.TypeRes = P.typINTEGER then
          begin
            S := '   result.AsInteger := ';
            TypeRes := 'typeINTEGER';
          end
          else if P.TypeRes = P.typDOUBLE then
          begin
            S := '   result.AsDouble := ';
            TypeRes := 'typeDOUBLE';
          end
          else
          begin
            S := '   result.PValue^ := ';
            SignEx := false;
          end;
        end
        else
          S := '';

        S := S + SourceUnitName + '.' + 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