[Back to MISC SWAG index] [Back to Main SWAG index] [Original]

    {
    (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.

[Back to MISC SWAG index] [Back to Main SWAG index] [Original]