Current Shareware 1994 January/SHAR194.ISO/modem/ter110.zip/TER110.EXE/PASCAL._XE/MAKEBBS.PAS

Pascal/Delphi Source File | 1993-06-07 | 6KB | 213 lines

Program FilesBBSmaker;

{ This utility will search all the filelists specified in MAKEBBS.CFG    }
{ for decriptions and create a FILES.BBS, usefull if you have a large    }
{ download directory and you don't know the descriptions for the files   }
{ Then this program will do all the work for you. 1993 by Bo Bendtsen    }
{ Totally freeware, make any modifications you like, just remember to    }
{ give some thanx or credits to me.                                      }

Uses Crt,Dos;

Var
  I,Out      : Text;
  Buf        : Array[1..40960] of byte;       { For reading textfiles faster }
  Info       : SearchRec;
  Name       : Array[1..1000] of String[12];  { Max 1000 filenames }
  L,X,Y,left : Word;
  Stop       : Boolean;
  C          : Longint;
  S,UPS      : String;
  StartPos,p : Byte;
  Filelist   : Array[1..20] of Record
                               F        : String[60];
                               StartPos : Byte;
                             End;
  Lister     : Byte;  { how many filelists }

Function GrabWord(S: String; B: Byte) : String;
Var st,e:Byte;
    return : String[80];
Begin
  Return:='';
  st:=1;e:=1;
  While B>0 Do
  Begin
    While (S[st]=' ') or (S[st]=#9) Do Inc(st);  { #9 er TAB }
    e:=st;
    While (S[e]<>' ') And (e<=Length(s)) Do Inc(e);
    Return:=Copy(S,st,e-st);
    st:=e;
    Dec(B);
  End;
  GrabWord:=Return;
End;

Function StrToInt(S: String) : LongInt;
Var
  Kode : Integer;
  i    : LongInt;
  b    : Byte;
Begin
  b:=Length(s);
  While b>0 Do
  Begin
    If s[b] in [#0..#255]-['0'..'9'] Then Delete(s,b,1);
    Dec(b);
  End;
  If Length(S) = 0 Then StrToInt := 0 Else Begin
    Val(S,i,Kode);
    If Kode = 0 Then StrToInt := i Else StrToInt := 0;
  End;
End;

Function StUpcase(s:string):string;
Var i :byte;
Begin
  for i := 1 to Length(s) do s[i] := UpCase(s[i]);
  StUpcase:=s;
End;

Function BlankAfter(S : String; Len : Byte): String;
var
  o : string;
  SLen : Byte absolute S;
Begin
  If Length(S) >= Len then BlankAfter := S
  Else begin
    o[0] := Chr(Len);
    Move(S[1], o[1], SLen);
    if SLen < 255 then FillChar(o[Succ(SLen)], Len-SLen, ' ');
    BlankAfter := o;
  End;
End;

Begin
  TextAttr:=7; ClrScr; TextAttr:=16*7;
  WriteLn('╒═════════════════════════════════════════════════════════════════════════════╕');
  WriteLn('│     Filelist description searcher 1.00, made by Bo Bendtsen [phone]    │');
  WriteLn('╘═════════════════════════════════════════════════════════════════════════════╛'#10);
  TextAttr:=7;

  If paramcount=0 Then
  Begin
    WriteLn('This program will read all files specified in a directory and search the');
    WriteLn('for descriptions in the filelists specified in MAKEBBS.CFG');
    WriteLn(#10'Syntax: MAKEBBS path+wildcard');
    WriteLn(   '        MAKEBBS C:\TERMINAT\DOWNLOAD\*.*');
    WriteLn(   '        MAKEBBS C:\TERMINAT\DOWNLOAD\*.GIF');
    Halt;
  End;

  Assign(I,Copy(ParamStr(0),1,Length(ParamStr(0))-3)+'CFG');
  {$I-} Reset(I); {$I+}

  If IOResult<>0 Then
  Begin
    WriteLn('Unable to open config file');
    Halt;
  End;
  Lister:=0; Fillchar(Filelist,sizeof(filelist),0);

  While Not Eof(i) And (Lister<20) Do
  Begin
    ReadLn(I,S);
    If (S<>'') And Not (S[1] in [';','%']) Then
    Begin
      Inc(Lister);
      Filelist[Lister].F:=GrabWord(S,1);
      Filelist[Lister].StartPos:=StrToInt(GrabWord(S,2));
      If Filelist[Lister].StartPos=0 Then Filelist[Lister].StartPos:=1;
    End;
  End;

  L:=0; Fillchar(Name,sizeof(name),0);
  WriteLn('Reading files '+Paramstr(1));
  FindFirst(Paramstr(1),Archive,Info);
  While (DosError=0) And (L<1000) Do
  Begin
    If l mod 25=0 Then Write(#13,l);
    Inc(L);
    Name[L]:=Info.Name;
    If Pos('.',Name[L])=0 Then Name[L]:=Name[L]+'.';
    FindNext(Info);
  End;
  Left:=L;

  If L=0 Then
  Begin
    WriteLn('No files to find');
    Halt;
  End;

  Assign(Out,'FILES.BBS');
  {$I-} Append(Out); {$I+}
  If IOResult<>0 Then
  Begin
    {$I-} Rewrite(Out); {$I+}
    If IOResult<>0 Then
    Begin
      WriteLn('Unable to write to FILES.BBS');
      Halt;
    End;
    WriteLn(#13#10'Creating FILES.BBS');
  End
  Else WriteLn(#13#10'Appending to FILES.BBS');

  For y:=1 to Lister Do
  Begin

    WriteLn(FileList[y].F);
    Assign(I,FileList[y].F);
    SetTextBuf(I,Buf);
    {$I-} Reset(I); {$I+}
    If IOResult<>0 Then WriteLn('Unable to open input file')
    Else Begin
      WriteLn(Out);
      WriteLn(Out,' - MakeBBS : '+FileList[y].F);
      WriteLn(Out);

      StartPos:=Filelist[y].StartPos;

      Stop:=False; C:=0;
      While Not Eof(I) And Not Stop And (Left>0) Do
      Begin
        Inc(C);
        If C Mod 100=0 Then
        Begin
          Stop:=KeyPressed;
          Write(#13,'Lines: ',C,', missing ',Left,'      ');
        End;
        ReadLn(I,S);
        UPS:=StUpcase(S);
        For x:=1 To L Do
        Begin
          If Pos(Name[x],UPS)=StartPos Then
          Begin
            Dec(Left);
            WriteLn(Out,S);
            Name[x]:='';
          End
          Else Begin
            p:=Pos('.',Name[x]);
            If Pos(Copy(Name[x],1,p-1),UPS)=StartPos Then
            Begin
              Dec(Left);
              If Name[x][Length(Name[x])]='.' Then Name[x][0]:=Chr(Ord(Name[x][0])-1);
              WriteLn(Out,BlankAfter(Name[x],12)+Copy(S,13,255));
              Name[x]:='';
            End
          End;
        End;
      End;

      WriteLn(#13#10'Lines processed: ',C);

      Close(I);
    End;

  End;

  Close(Out);
End.