home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Hacks & Cracks
/
Hacks_and_Cracks.iso
/
programs
/
x-brain
/
tools
/
fcomp.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1998-11-19
|
12KB
|
382 lines
{ Ja, ja ihr habt ja recht...ist ein bischen unordentlich aber ich hab keine
Zeit für ein schönen SourceCode! Also versuchts zu entziffern oder laßts
sein! --- Eigentlich ganz einfach und simple & ein wenig langsam... :}
uses dos,crt;
const bufsize = 16384;
clockchar = 10;
ta : array [1..clockchar] of char = #229#230#231#232#233#234#235#236#238#237;
nohack = 'Beide Dateien sind inhaltlich vollkommen identisch!';
hack = 'O.K. done...HaPpY hAcKyInG...';
verpos = 'Verglichen bis filepos.: ';
abort = '%) ... Abbruch durch user!'#13#10;
dfp1 = 'ERROR: Kann Datei : ';
dfp2 = ' nicht öffnen!';
HexList :ARRAY[0..15] OF CHAR ='0123456789ABCDEF';
VideoSeg : Word = $b800 ;
var FromF, ToF: file;
tf : text;
x, NumRead, NumWritten: Word;
buf,fub: array[1..bufsize] of Char;
percent, y, counter : byte;
hex, found : boolean;
ld, foundn,d,readcount,fsize,fpos : longint;
cracker, title : string[50];
reg : registers;
Procedure fastwrite(x, y, attr : Byte; Zlika : String); assembler;
Asm
Mov ES, VideoSeg
DEC Y
Mov AL, 160
Mul Byte Ptr y
Mov BL, x
Xor BH, BH
ShL BX, 1
Add BX, AX
Push DS
ClD
LDS SI, Zlika
LodSB
Mov CL, AL
Xor CH, CH
Mov DI, BX
Mov AH, attr
@Boucle:
LodSB
StoSW
Loop @Boucle
Pop DS
end ;
procedure cursor(onoff:boolean);
begin
if onoff then begin
ASM
MOV AH, 1
MOV CX, 0607h
INT 10h
end;
end
else
begin
asm
MOV AH, 1
MOV CX, 1400h
INT 10h
end;
END;
end;
FUNCTION HiWord( Long :LONGINT ) :WORD; ASSEMBLER;
ASM
Mov AX,Long.WORD[2]
END;
FUNCTION LoWord( Long :LONGINT ) :WORD; ASSEMBLER;
ASM
Mov AX,Long.WORD[0]
END;
FUNCTION BHex( V :BYTE ) :STRING;
BEGIN
BHex := HexList[V Shr 4] + HexList[V Mod 16];
END;
FUNCTION WHex( V :WORD ) :STRING;
BEGIN
WHex := Bhex(Hi(V)) + BHex(Lo(V));
END;
FUNCTION LHex( Long :LONGINT ) :STRING;
BEGIN
LHex := WHex(HiWord(Long))+WHex(LoWord(Long));
END;
function UpStr(s:string):string; assembler;
asm
push ds
lds si,s
les di,@result
lodsb
stosb
xor ch,ch
mov cl,al
jcxz @empty
@upperLoop:
lodsb
cmp al,'a'
jb @cont
cmp al,'z'
ja @cont
sub al,' '
@cont:
stosb
loop @UpperLoop
@empty:
pop ds
end;
procedure fireball;
type
bytearray=array[0..15] of byte;
chararray=array[0..8] of record
chn:byte;
chardata:bytearray;
end;
const
newchars:chararray=(
(chn:229; chardata:(0,0,127,249,193,193,192,252,228,196,192,192,196,128,128,128)),
(chn:230; chardata:(0,16,16,24,24,28,28,28,28,28,20,20,20,16,16,0)),
(chn:231; chardata:(0,0,224,248,222,211,211,198,252,240,248,220,206,198,132,132)),
(chn:232; chardata:(0,126,255,195,193,193,192,241,249,200,200,192,193,255,126,0)),
(chn:233; chardata:(0,0,0,0,0,0,0,255,255,140,136,8,8,0,0,0)),
(chn:234; chardata:(0,0,252,254,215,215,222,248,252,214,211,195,199,253,249,193)),
(chn:235; chardata:(0,0,24,60,110,110,110,203,203,255,203,203,203,193,193,129)),
(chn:236; chardata:(0,128,128,192,192,192,192,224,224,224,224,224,252,126,3,1)),
(chn:255; chardata:(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)));
begin
for x:=0 to 8 do
begin
with reg do
begin
ah:=$11;
al:=$0;
bh:=$10;
bl:=0;
cx:=1;
dx:=newchars[x].chn;
es:=seg(newchars[x].chardata);
bp:=ofs(newchars[x].chardata);
intr($10,reg);
end;
end;
end;
procedure clock;
type
bytearray=array[0..15] of byte;
chararray=array[0..clockchar] of record
chn:byte;
chardata:bytearray;
end;
const
newchars:chararray=(
(chn:229; chardata:(0,126,255,255,255,126,126,60,24,36,66,66,129,129,129,126)),
(chn:230; chardata:(0,126,225,255,255,126,126,60,24,44,74,74,137,137,129,126)),
(chn:231; chardata:(0,126,129,227,247,126,126,60,24,44,74,74,137,137,189,126)),
(chn:232; chardata:(0,126,129,129,227,118,126,60,24,44,74,74,137,157,255,126)),
(chn:233; chardata:(0,126,129,129,129,98,126,60,24,44,74,74,157,255,255,126)),
(chn:234; chardata:(0,126,129,129,129,66,102,60,24,44,74,126,255,255,255,126)),
(chn:235; chardata:(0,126,129,129,129,66,66,36,24,60,126,126,255,255,255,126)),
(chn:236; chardata:(0,0,126,255,189,129,66,60,24,60,126,255,255,126,0,0)),
(chn:237; chardata:(0,0,126,255,255,126,60,24,60,66,129,189,255,126,0,0)),
(chn:238; chardata:(0,0,0,0,0,60,126,255,255,126,60,0,0,0,0,0)),
(chn:255; chardata:(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)));
begin
for x:=0 to clockchar do
begin
with reg do
begin
ah:=$11;
al:=$0;
bh:=$10;
bl:=0;
cx:=1;
dx:=newchars[x].chn;
es:=seg(newchars[x].chardata);
bp:=ofs(newchars[x].chardata);
intr($10,reg);
end;
end;
end;
procedure checkforstr;
begin
d:=0;
repeat
inc(d);
if buf[d] <> fub[d] then begin
if not found then begin
{$I-}
Assign(tf,'CRACKPOS.TXT');
rewrite(tf);
{$I+}
if ioresult <> 0 then begin writeln(' Kann Protokolldatei " CRACKPOS.TXT " nicht erstellen!'); halt; end;
gotoxy(51,y);write('Protokolldatei:');textcolor(11);write(' CRACKPOS.TXT');textcolor(7);
textattr:=12; gotoxy(29,y); write('FOUND!'); cursor(true); textattr:=15;
gotoxy(1,y-1); clreol;
gotoxy(1,y-1); write('Enter ProgramTitle: '); textattr:=10; readln(title);
gotoxy(1,y-1); clreol; textattr:=15;
gotoxy(1,y-1); write('Enter CrackerName : '); textattr:=10; readln(cracker);
cursor(false);
textattr:=7;
gotoxy(1,y-1); clreol;
writeln(tf,'Dateivergleich von ORG.:"',upstr(paramstr(1)),'" mit CRK.:"',upstr(paramstr(2)),'".');
write(tf,'Erstelle X-BRAIN Eintrag:',#13#10#10,'TITLE: ',title,#13#10,'CRACKER: ',cracker,#13#10,'FILE.SEARCH: '
,upstr(paramstr(2)),'; #',filesize(ToF));
found:=true; end;
inc(foundn); gotoxy(29,y); write('found($'); textattr:=14; write(foundn); textattr:=07; write(')');
(* Entry von der alten Version:
writeln(tf,'pos.: ',fpos+d-1,' / (',lhex(fpos+d-1),') ... char: <',buf[d],'> & <',fub[d],
'> / [#',ord(buf[d]),'..#',ord(fub[d]),'] [',bhex(ord(buf[d])),#46#46,bhex(ord(fub[d])),#93); *)
if hex then if (buf[d-1] = fub[d-1]) then
write(tf,#13#10,'PATCH.STR: ',lhex(fpos+d-1),'h; ',bhex(ord(fub[d])),'h') else
write(tf,' ',bhex(ord(fub[d])),'h')
else
if (buf[d-1] = fub[d-1]) then begin if foundn > 1 then write(tf,'>');
write(tf,#13#10,'PATCH.STR: ',lhex(fpos+d-1),'h; <',fub[d]); end else
write(tf,fub[d]);
end;
until (d=bufsize) or (keypressed);
for ld := 1 to bufsize do buf[ld]:=#0;
for ld := 1 to bufsize do fub[ld]:=#0;
end;
begin
textattr:=07;write('Filecomparer v1.2 by ');textcolor(14); write('FIRE-BALL');
textcolor(7); writeln(' / sTRONTIUm 9000 *-*-* Tastendruck = Abbruch.');
if paramstr(2) = '' then begin writeln('Angabefehler! ---[ FCOMP ORGFILE.EXE CRKFILE.EXE ]--- ',#13#10,
' parameter(3): FCOMP ORGF.EXE CRKF.EXE TXT - output in <...> as in hex.');
halt; end;
{$I-}
Assign(FromF, paramstr(1));
Reset(FromF, 1);
{$I+}
if ioresult <> 0 then begin
writeln(#13#10,dfp1,upstr(paramstr(1)),dfp2); halt; end;
{$I-}
Assign(ToF, paramstr(2));
Reset(ToF, 1);
{$I+}
if ioresult <> 0 then begin
writeln(#13#10,dfp1,upstr(paramstr(2)),dfp2); halt; end;
cursor(false);
writeln('Vergleiche: "',upstr(paramstr(1)),'" mit "',upstr(paramstr(2)),'" :-) :)');
write('OutPutModi: ');
if upstr(paramstr(3)) = 'TXT' then begin hex:=false; writeln('TextMode <...>'); end else
begin hex:=true; writeln('HexMode ...h'); end;
clock;
y:=wherey;
for ld := 1 to bufsize do buf[ld]:=#0;
for ld := 1 to bufsize do fub[ld]:=#0;
fsize:=filesize(fromf);
found:=false;
readcount:=0;
fpos:=0;
counter:=1;
foundn:=0;
write('Status : σ ---> 0%');
repeat
if counter > clockchar then counter:=1;
gotoxy(13,y);write(ta[counter]);
inc(counter);
fpos:=readcount*bufsize;
seek(FromF,fpos);
BlockRead(FromF,buf,bufsize,NumRead);
seek(ToF,fpos);
BlockRead(ToF,fub,bufsize,numwritten);
checkforstr; gotoxy(20,y);
If ((Fpos+bufsize) <= FSize) Then Percent := (((Fpos+bufsize) * 100) Div Fsize ) Else Percent := 100;
write(percent,#37); inc(readcount);
until (NumRead = 0) or (NumWritten <> NumRead) or (keypressed);
gotoxy(13,y);write(ta[9]);
fireball; fastwrite(21,y-4,14,#229#230#231#232#233#234#235#236#236);
if (foundn > 1) and not (hex) then write(tf,'>');
if found then begin writeln(#13#10,Hack);writeln(tf,#13#10#10,Hack); end
else writeln(#13#10,NoHack);
if keypressed then begin
If ((Fpos+d-1) <= FSize) Then Percent := (((Fpos+d-1) * 100) Div Fsize ) Else Percent := 100;
if (fpos+d-1) > fsize then fpos:=fsize else fpos:=fpos+d-1;
if found then write(Tf,Verpos,fpos,' (',percent,Abort);
write(Verpos,fpos,' (',percent,Abort); end;
if found then close(tf);
Close(FromF);
Close(ToF);
cursor(true);
end.
(****************************************************************************)
(**************************** C R E A T E F I L E ***************************)
(****************************************************************************)
var d, fsize : longint;
i : integer;
f : text;
name : string;
dummy : byte;
ch : char;
s : string[1];
begin
if paramstr(2) = '' then begin writeln('FileCreator v1.1'#13#10'Usage: CREATEF <NAME> <SIZE> <CHAR>'#13#10,
' if none <CHAR> given fillchar = space (20h)'); halt; end;
if paramstr(3) <> '' then s:=paramstr(3) else s := ' ';
name:=paramstr(1);
val(paramstr(2),fsize,i);
writeln('fillchar: "',s,'"');
writeln('creating "'+name+'"...(',fsize,')');
assign(f,name);
rewrite(f);
for d := 1 to fsize do write(f,s);
close(f);
dummy:=length(name)+1; repeat delete(name,dummy,1); dec(dummy); until (name[dummy]='.') or (dummy=0);
if dummy=0 then name:='X.';
writeln('creating "'+name+'org"...(',fsize,')');
assign(f,name+'org');
rewrite(f);
for d := 1 to fsize do write(f,s);
close(f);
writeln('done.');
end.
(****************************************************************************)
(****************************** C U T S P A C E *****************************)
(****************************************************************************)
uses crt;
var i : byte;
d : word;
s : string;
f,f2 : text;
counter : longint;
begin
if paramstr(2) = '' then begin writeln('This util cuts SpaceChars from the end of a line, to spare bytes.',
#13#10,'Usage: CUTSPACE infile outfile'); halt; end;
{$I-}
assign(f,paramstr(1));
reset(f);
{$I+}
if ioresult <> 0 then begin writeln('Error opening: " ',paramstr(1),' " !'); halt(1); end;
{$I-}
assign(f2,paramstr(2));
rewrite(f2);
{$I+}
if ioresult <> 0 then begin writeln('Error creating: " ',paramstr(2),' " !'); halt(1); end;
d:=1;
counter:=1;
writeln('converting: "',paramstr(1),'" to "',paramstr(2),'"...');
repeat
readln(f,s);
i:=length(s)+1;
dec(counter);
repeat
delete(s,i,1);
dec(i);
inc(counter);
until s[i] <> ' ';
writeln(f2,s);
inc(d);
gotoxy(1,wherey);write(d,' lines done.');
until eof(f);
writeln(' ---> ',counter-1,' bytes spared!');
close(f);
close(f2);
end.