dedepas.pas

dede 的源代码 3.10b

      ObjectBinaryToText(S,STxt);
    finally
      STxt.Free;
    end ;

    S.Position := Pos0;
    GeneratePas(S,DFMName,ParentName,'');
  finally
    S.Free;
  end ;
end ;


function WasUsed(S: String): boolean;
begin
  Result := UsesList.IndexOf(S)>=0;
end ;

procedure AddUses(S: String);
begin
  if WasUsed(S) then
    Exit;
  UsesList.Add(S);
end ;

function ConvertHeader: TComponentInfo;
var
  pfxFlags: TFilerFlags;
  pfxPos: Integer;
  ClassName, ObjectName: String;
begin
  Result := Nil;
  Reader.ReadPrefix(pfxFlags, pfxPos);
  ClassName := Reader.ReadStr;
  ObjectName := Reader.ReadStr;
  if ObjectName='' then
    Exit;
  if NestingLevel>0 then begin
    PropList.Add(Format(' %s%s: %s;%s',[B1[ffInherited in pfxFlags],
         ObjectName,ClassName,B2[ffInherited in pfxFlags]]));
   end
  else begin
    MainFlags := pfxFlags;
    MainClassName := ClassName;
    MainObjectName := ObjectName;
  end ;
  Result := GetComponentInfo(ClassName);
  if (Result<>Nil)and(Result.UnitName<>'') then
    AddUses(Result.UnitName);
end ;

procedure ConvertProperty(CI: TComponentInfo); forward;

procedure ConvertBinary;
const
  BytesPerLine = 32;
var
  I: Integer;
  Count: Longint;
  Buffer: array[0..BytesPerLine - 1] of Char;
begin
  Reader.ReadValue;
  Inc(NestingLevel);
  Reader.Read(Count, SizeOf(Count));
  while Count > 0 do
  begin
    if Count >= 32 then I := 32 else I := Count;
    Reader.Read(Buffer, I);
    Dec(Count, I);
  end;
  Dec(NestingLevel);
end;

function ConvertValue: String;
var
  S: string;
begin
  Result := '';
  case Reader.NextValue of
    vaList:
      begin
        Reader.ReadValue;
        Inc(NestingLevel);
        while not Reader.EndOfList do
          ConvertValue;
        Reader.ReadListEnd;
        Dec(NestingLevel);
      end;
    vaInt8, vaInt16, vaInt32:
      Reader.ReadInteger;
    vaExtended:
      Reader.ReadFloat;
    vaString, vaLString:
      Reader.ReadString;
    vaIdent:
      Result := Reader.ReadIdent;
    vaFalse, vaTrue, vaNil:
      Reader.ReadIdent;
    vaBinary:
      ConvertBinary;
    vaSet:
      begin
        Reader.ReadValue;
        while True do
        begin
          S := Reader.ReadStr;
          if S = '' then Break;
        end;
      end;
    vaCollection:
      begin
        Reader.ReadValue;
        Inc(NestingLevel);
        while not Reader.EndOfList do
        begin
          if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then
          begin
            ConvertValue;
          end;
          //Reader.CheckValue(vaList);
          if Reader.ReadValue<>vaList then {Ignore};
          Inc(NestingLevel);
          while not Reader.EndOfList do ConvertProperty(Nil);
          Reader.ReadListEnd;
          Dec(NestingLevel);
        end;
        Reader.ReadListEnd;
        Dec(NestingLevel);
      end;
  end;
end;

procedure ConvertProperty(CI: TComponentInfo);
var
  Name,V,M: String;
begin
  Name := Reader.ReadStr;
  V := ConvertValue;
  if CI=Nil then
    Exit;
  if (Name='')or(V='') then
    Exit;
  M := CI.GetPropertyMethod(Name,V);
  if M<>'' then
    MethodList.Add(M);
end;

procedure ConvertObject;
var
  CI: TComponentInfo;
begin
  CI := ConvertHeader;
  Inc(NestingLevel);
  while not Reader.EndOfList do ConvertProperty(CI);
  Reader.ReadListEnd;
  while not Reader.EndOfList do ConvertObject;
  Reader.ReadListEnd;
  Dec(NestingLevel);
end;

procedure WriteUsesList;
const
  Sep: array[boolean] of PChar = (', ',','#13#10'  ');
var
  i: integer;
begin
  for i:=0 to UsesList.Count-1 do
    Write(PasF,Sep[(i mod 6)=0],UsesList[i])
end ;

procedure WriteHdrList(S0: String; L: TStrings);
var
  i: integer;
begin
  for i:=0 to L.Count-1 do
    Writeln(PasF,S0,L[i]);
end ;

procedure WriteBodyMethods;
var
  i: integer;
  S: String;
  CP: PChar;
  NameP: String;
begin
  NameP := MainClassName+'.';
  for i:=0 to MethodList.Count-1 do begin
    S := MethodList[i];
    CP := StrScan(PChar(S),' ');
    if CP<>Nil then
      Insert(NameP,S,CP-PChar(S)+2);
    Writeln(PasF,S,#13#10'begin'#13#10'  {Auto}'#13#10'end ;'#13#10);
  end ;
end ; 

function GeneratePASCALFile(Stream : TMemoryStream; Offset,Size : DWORD; sPasFileName, sParentName,sParentUnit : String) : String;
var S: TMemoryStream;
begin
  S:=TMemoryStream.Create;
  PropList.Clear;
  MethodList.Clear;
  UsesList.Clear;
  Try
    S.LoadFromStream(Stream);

    sPasFileName := ChangeFileExt(sPasFileName,'.pas');
    AssignFile(PasF,sPasFileName);
   {$I-}
    rewrite(PasF);
   {$I+}
    if IOResult<>0 then
      raise Exception.CreateFmt(err_cant_open_file,[sPasFileName]);
    try
      LoadComponentDescrs;
      try
        MethodList := TStringList.Create;
        PropList := TStringList.Create;
        UsesList := TStringList.Create;
        try
          MethodList.Sorted := true;
          MethodList.Duplicates := DupIgnore;
          {UsesList.Sorted := true;
          UsesList.Duplicates := DupIgnore;}
          AddUses('Controls');
          AddUses('Forms');
          AddUses('Dialogs');
          UnitName := ExtractFileName(sPasFileName);
          UnitName := ChangeFileExt(UnitName,'');
          Write(PasF,
          'unit ',UnitName,';'#13#10+
          #13#10+
          'interface'#13#10+
          #13#10+
          'uses'#13#10+
          '  Windows, Messages, SysUtils, Classes, Graphics');
          S.Seek(0,soFromBeginning);
          Reader := TReader.Create(S, 4096);
          try
            NestingLevel := 0;
            Reader.ReadSignature;
            ConvertObject;
            if (ffInherited in MainFlags)or(sParentUnit<>'') then
              AddUses(sParentUnit);
            WriteUsesList;
            Writeln(PasF,';'#13#10#13#10'type');
            if not(ffInherited in MainFlags)and(sParentName='') then
              sParentName := 'TForm';
            Writeln(PasF,'  ',MainClassName,'=class(',sParentName,')');
            WriteHdrList('  ',PropList);
            WriteHdrList('    ',MethodList);
            Writeln(PasF,
            '  private'#13#10+
            '    { Private declarations }'#13#10+
            '  public'#13#10+
            '    { Public declarations }'#13#10+
            '  end ;'#13#10);
            if MainObjectName<>'' then begin
              Writeln(PasF,'var'#13#10'  ',MainObjectName,': ',MainClassName,';'#13#10);
            end ;
          finally
            Reader.Free;
          end;
          Writeln(PasF,
          'implementation'#13#10+
          #13#10+
          '{$R *.DFM}'#13#10+
          #13#10);
          WriteBodyMethods;
          Writeln(PasF,'end.');
          ShowMessage(Format('PAS with %s was generated (%d components, %d events).',
            [MainClassName,PropList.Count,MethodList.Count]));
        finally
        end ;
      finally
        FreeComponentDescrs;
      end ;
    finally
      Close(PasF);
    end ;
  Finally
    S.Free;
  End;
end;

procedure Convert(S : TMemoryStream; ParentName : String); overload;
var
  Pos0: LongInt;
  STxt: TFileStream;
begin
    S.ReadResHeader;
    Pos0 := S.Position;

    STxt := TFileStream.Create(FsTEMPDir+'dfm.$$$',fmCreate);
    try
      ObjectBinaryToText(S,STxt);
    finally
      STxt.Free;
    end ;

    S.Position := Pos0;
    //GeneratePas(S,'dfm',ParentName,'');
end ;

procedure GenerateDPR(AsProject,AsProjectFileName : String; UnitList,DFMList : TStringList; ProgramEntryPoint,RVA : DWORD);
var s : String;
    i : Integer;
    DPRList, TmpList : TStringList;
begin
  DPRList:=TStringList.Create;
  Try
    DPRList.Add('{'+txt_copyright+'}');
    DPRList.Add('');
    DPRList.Add('Project '+AsProject+';');
    DPRList.Add('');
    DPRList.Add('Uses');
    //DPRList.Add('  Forms,');  {stuppied ~~!!}
    For i:=0 To UnitList.Count-2 Do
      Begin
        s:=Format('  %s in ''%s.pas'' {%s},',[UnitList[i],UnitList[i],DFMList[i]]);
        DPRList.Add(s);
      End;
    i:=UnitList.Count-1;
    if i>=0 then s:=Format('  %s in ''%s.pas'' {%s};',[UnitList[i],UnitList[i],DFMList[i]]);

    DPRList.Add(s);
    DPRList.Add('');
    DPRList.Add('{$R *.RES}');
    DPRList.Add('');
    DPRList.Add('begin');
    DPRList.Add('{');

     // New Version Of DPR Save
     PEStream.Seek(ProgramEntryPoint,soFromBeginning);

     Try
      DisassembleProc('','',TmpList,False,True);
      For i:=0 To TmpList.Count-1 Do DPRList.Add(TmpList[i]);
     Finally
      // Frees Disaasembly Result String List
      TmpList.Free;
     End;

    DPRList.Add('}');
    DPRList.Add('end.');
    DPRList.SaveToFile(AsProjectFileName);
  Finally
    DPRList.Free;
  End;
end;

procedure StartNewPas(var str : TMemoryStream; sUnitName : String);
const q1 = 'unit ';
const q2 = #13#10#13#10'interface'#13#10#13#10'uses'#13#10+
           '  Windows, Messages, SysUtils, Classes, Graphics,'#13#10+
           '  Controls, Forms, Dialogs, StdCtrls'#13#10;
begin
  sUnitName:=sUnitName+';';
  Str:=TMemoryStream.Create;
  Str.WriteBuffer(q1[1],Length(q1));
  Str.WriteBuffer(sUnitName[1],Length(sUnitName));
  Str.WriteBuffer(q2[1],Length(q2));
end;

initialization


finalization


end.