Contributor: JONAS MAEBE
{
(BTW: it requires a 386 or up to run). It should be
(almost) bug free, since my boss has been running it for about a month by now
and all problems he has found have been fixed.
------------- BBSCAN.PAS -------------------
}
Program bbscan;
{$g+,a+,q-,r-,i-,q-,s-,n-,e-,x+,f-}
Uses crt, dos;
Const l = 20; {maxlength of areanames, limit of Squish statistics tools}
maxareas = (65504-2) div (l+1); {around 3000}
Type areaarray = Record
nofareas: Word;
area: Array[0..maxareas] of String[l]
End;
Const ProgName = 'BackboneScan v1.14, Copyright (c) Gamefreak 1996';
fs = 64ドル;
pop_fs = $a10f;
Fidoexists: Boolean = true;
VAR fido, bb, newfido: TEXT;
areas: ^areaarray;
c1, c2: Word;
tempstr: String;
Asort: Array[0..maxareas] of Word;
PROCEDURE Init;
VAR iocheck: Integer;
f: file;
BEGIN
ClrScr;
WRITELN(ProgName);
WRITELN;
Assign(f, 'backbone.in');
{$i-}
Reset(f);
{$i+}
iocheck := ioresult;
IF iocheck 0 THEN
CASE iocheck OF
2,3: BEGIN
WRITELN('File "backbone.in" not found. Please move this program into the right dir');
WRITELN('and run it again.');
WRITELN;
HALT(iocheck)
END
ELSE
BEGIN
WRITELN('An error (',iocheck,') occurred while opening the file "fidonet.na".'); WRITELN;
HALT(iocheck)
END
END;
IF FileSize(f) = 0 THEN
BEGIN
WRITELN('Size of file "backbone.in" = 0 bytes. Nothing to do.');
WRITELN;
HALT(1)
END;
close(f);
assign(f, 'fidonet.na');
{$i-}
reset(f);
{$i+}
If ioresult 0 Then
Begin
rewrite(f);
fidoexists := false
End
Else if filesize(f) = 0 Then fidoexists := false;
close(f);
Assign(fido, 'fidonet.na');
reset(fido);
Assign(bb, 'backbone.in');
Reset(bb)
END;
PROCEDURE ReadAreaNames;
Var tempstr2: String[12+30];
Function Duplicate: Boolean;
Assembler;
Asm
cld
les di, areas
mov dx, [es:di] {dx = nofareas}
xor al, al
test dx, dx
jz @end
add di, 2 {es:di = 1st string}
xor cx, cx
mov si, offset tempstr {ds:si points to tempstr}
mov bl, [si] {bx = length(tempstr)}
mov bh, bl
and bh, 11b {bh = length(tempstr) mod 4}
shr bl, 2 {bl = length(tempstr) div 4}
mov ax, di {save di in ax}
@loop:
mov cl, bl {cl = length(tempstr) div 4}
xor ch, ch
db 66ドル; repe cmpsw {compare}
jne @ok {not equal? -> ok}
mov cl, bh {otherwise check remaining bytes}
repe cmpsb
je @equal
@ok:
mov si, offset tempstr {ds:si points to tempstr}
add ax, l + 1 {let ax point to next string}
mov di, ax {and move it into si}
dec dx {decrease the number of areas}
jnz @loop {if not zero -> loop}
xor al, al {no equal string -> false}
jmp @end
@equal:
mov al, 1 {equal -> true}
@end:
END;
BEGIN
WRITELN('Reading areanames from "Backbone.in" and removing duplicates...');
WRITELN;
IF maxavail < 65535 THEN BEGIN WRITELN('Not enough memory available.'); WRITELN; close(bb); close(fido); HALT(8) END ELSE new(areas); fillchar(areas^, sizeof(areas^), 0); While (areas^.nofareas < maxareas) and not(eof(bb)) Do BEGIN Readln(bb, tempstr); ASM cld {this part copies the areaname} push ds {to the front of the string} mov di, offset tempstr {and removes the "xxx messages} mov dx, di {scanned/tossed" part.} mov si, di add si, 12 pop es {es:di = sortstr[0]} xor cx, cx mov al, ' ' {used to check length of areaname} mov cl, byte[di] {cl = length total string} add di, 12 {es:di = sortstr[12]} sub cl, 12 mov bx, cx {save original length - 12} dec bx repne scasb {scan until a space is encouterd-> eof areaname}
sub bx, cx {calc length of areaname}
mov cx, bx {move length(areaname in cx)}
mov di, dx
mov [di], cl {move length of areaname in lengthbyte}
inc di {points to first char of string}
shr cx, 1
jnc @even
movsb
@even:
rep movsw {move the areaname to the front}
END;
If not(duplicate) Then
With areas^ Do
BEGIN
area[nofareas] := tempstr;
inc(nofareas)
END
END;
Dec(areas^.nofareas);
close(bb)
END;
Procedure Sort;
Var areasofs: Word;
Begin
Writeln('Sorting areanames...');
Writeln;
Asm
push ds
push ds
dw pop_fs
cld
les di, areas
mov dx, word[es:di]
mov bx, dx
add bx, bx
add bx, offset asort
@asortinit:
mov [bx], dx
sub bx, 2
dec dx
jnz @asortinit
mov dx, [es:di]
dec dx
jl @end
mov ax, dx {ax = pred(areas^.nofareas)}
xor dx, dx
lds si, areas
add si, 3
mov areasofs, si
xor bx, bx {bx = c2}
@outloop:
mov di, areasofs
db fs; mov cx, [bx+offset asort+2]
add di, cx
shl cx, 2
add di, cx
shl cx, 2
add di, cx
@loop:
mov si, areasofs
db fs; mov cx, [bx+offset asort]
add si, cx
shl cx, 2
add si, cx
shl cx, 2
add si, cx
xor cx, cx
mov cl, [si-1]
cmp cl, [di-1]
jbe @length_ok
mov cl, [di-1]
@length_ok: {cl = length of shortest string}
push si
push di
rep cmpsb {compare the strings}
pop si {si = pushed di and di = pushed si, used so I}
pop di {have to recalculate di in the next loop}
jb @noswitch {if first < second, don't switch} ja @switch {if first> second, switch}
{if the prog gets here, the compared part was equal}
{so the longest string is the greatest}
mov cl, [di-1] {get length of first string (di has been switched}
{with si)}
cmp cl, [si-1] {compare with length of second string}
jbe @noswitch {length(string 1) < length(string 2) -> no switch}
@switch:
mov di, si
db fs; db 66ドル; ror word[bx+offset asort], 16
@noswitch:
sub bx,2 {decrease c2}
jns @loop {if above or equal 0 then loop}
inc dx {increase c1}
mov bx, dx {c2 = c1}
add bx, bx
cmp dx, ax {compare c1 with pred(areas^.nofareas)}
jbe @outloop {if below or equal, loop}
@end:
pop ds
End
End;
Procedure Update;
Const days : array [0..6] of String[9] =
('Sunday','Monday','Tuesday',
'Wednesday','Thursday','Friday',
'Saturday');
areasstillactive: Word = 0;
areasactivated: Word = 0;
areasstillnoflow: Word = 0;
areasnoflow: Word = 0;
newareascount: Word = 0;
Var tempstr2: String;
logfile: Text;
dofw, d, m, y: Word;
h,min,s: String[2];
Newareas: Array[0..maxareas] of Word;
Begin
Writeln('Writing new "Fidonet.na"...');
Writeln;
Assign(newfido, 'Newfido.na');
Rewrite(NewFido);
Assign(logfile, 'bbscan.log');
{$i-}
Append(logfile);
{$i+}
IF ioresult 0 Then Rewrite(logfile);
If fidoexists Then
Begin
Readln(fido,tempstr);
For c1 := 0 to areas^.nofareas Do
Begin
While ((tempstr < areas^.area[asort[c1]]) and not(eof(fido))) Do Begin If length(tempstr) <= l Then Begin Fillchar(tempstr[succ(length(tempstr))], l-length(tempstr), #20ドル); tempstr[0] :=char(l); tempstr := concat(tempstr, '[FiDo] No description available yet.') End; If tempstr[l+7] = ' ' Then Begin inc(areasstillnoflow) end Else Begin inc(areasnoflow); tempstr[l+7] := ' ' End; Writeln(NewFido, tempstr); ReadLn(fido, tempstr) End; ASM cld {This part copies the areaname out of} push ds {tempstr to tempstr2.} lea di, tempstr pop es mov al, ' ' xor bx, bx mov bl, [es:di] cmp bl, l+1 ja @length_ok inc bl mov [es:di+bx], al @length_ok: inc di mov cx, l+1 mov bx, l repne scasb sub bx, cx push ss mov cx, bx lea si, tempstr+1 pop es lea di, tempstr2 mov [es:di], cl inc di shr cx, 1 jnc @even movsb @even: rep movsw END; If tempstr2 = areas^.area[asort[c1]] Then Begin If length(tempstr) <= l Then Begin Fillchar(tempstr[succ(length(tempstr))],l-length(tempstr), #20ドル); tempstr[0] := char(l); tempstr := concat(tempstr, '[FiDo]*No description available yet.') End; If tempstr[l+7] = '*' Then inc(areasstillactive) Else Begin tempstr[l+7] := '*'; inc(areasactivated) End; Writeln(NewFido, tempstr); Readln(fido,tempstr) End Else Begin newareas[newareascount] := c1; inc(newareascount); tempstr2 := areas^.area[asort[c1]]; For c2 := 1 to (l-length(areas^.area[asort[c1]])) Do tempstr2 := concat(tempstr2,' '); tempstr2 := concat(tempstr2, '[FiDo]*New added area. No description available yet.'); WriteLn(newfido,tempstr2) End End End Else With areas^ Do Begin For c1 := 0 to nofareas Do Begin tempstr2 := area[asort[c1]]; For c2 := 1 to (l-length(area[asort[c1]])) Do tempstr2 := concat(tempstr2,' '); tempstr2 := concat(tempstr2, '[FiDo]*New added area. No description available yet.'); WriteLn(newfido,tempstr2) End End; If fidoexists Then Writeln('"Fidonet.na" has been successfully updated!') Else Writeln('"Fidonet.na" has been successfully created!'); Writeln; Writeln('Updating logfile (bbscan.log)...'); Writeln; Getdate(y, m, d, dofw); Write(logfile,'---------- ',days[dofw],', ', d:0,'/',m:0,'/',y:0,', '); Gettime(y, m, d, dofw); str(y,h); str(m,min); str(d,s); If length(h) = 1 Then h := concat('0',h); If length(min) = 1 Then min := concat('0',min); If length(s) = 1 Then s := concat('0',s); Writeln(logfile, h,':',min,':',s,'.'); If (newareascount> 0) Then
Begin
Writeln(logfile, 'New Areas:');
For c1 := 0 to pred(newareascount) Do
Begin
Write(logfile, areas^.area[asort[newareas[c1]]]:38);
If (succ(c1) mod 2 = 0) Then Writeln(logfile)
End
End;
If (succ(c1) mod 2 0) Then Writeln(logfile);
Writeln(logfile);
If not(fidoexists) Then newareascount := areas^.nofareas;
Writeln(logfile, 'Amount of new areas: ',newareascount);
Writeln(logfile, 'Areas still active: ',areasstillactive,'.');
Writeln(logfile, 'Areas activated: ',areasactivated,'.');
Writeln(logfile, 'Areas still down: ',areasstillnoflow,'.');
Writeln(logfile, 'Areas deactivated: ',areasnoflow,'.');
Writeln(logfile, 'Total number of areas:',newareascount+areasstillactive+areasactivated+areasstillnoflow+areasnoflow,'.');
Writeln(logfile);
close(logfile);
close(newfido);
close(fido);
{$i-}
assign(logfile, 'fidonet.bak');
Erase(logfile);
rename(fido, 'fidonet.bak');
rename(newfido, 'fidonet.na')
{$i+}
End;
Begin
Init;
ReadareaNames;
sort;
update
END.