home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DP Tool Club 19
/
CD_ASCQ_19_010295.iso
/
vrac
/
0151ter2.zip
/
0151TER2._XE
/
rar
/
PASCAL.EXE
/
MAKEBBS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-11-28
|
6KB
|
233 lines
{$M 16384,100000,100000}
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;
Const
MaxFiles = 4000;
Type
BufType = Array[1..32768] of Char;
Var
List,I,Out : Text;
Buf : ^BufType; { For reading textfiles faster }
CfgBuf : Array[1..1024] of Char;
OutBuf : Array[1..1024] of Char;
Info : SearchRec;
Name : Array[1..MaxFiles] of String[12]; { filenames in directory }
L,X,Y,left : Word;
Stop : Boolean;
C : Longint;
S,UPS : String;
StartPos,p : Byte;
DescPos : Byte;
ReadNext : Boolean;
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;
Procedure LookForMore; { Look for extra descriptions on following lines }
Begin
s:=' ';
While (s<>'') And (s[1]=' ') And Not Eof(I) Do
Begin
ReadLn(I,S);
If (s<>'') And (s[1]=' ') Then WriteLn(Out,s);
End;
ReadNext:=False;
End;
Begin
TextAttr:=7; ClrScr; TextAttr:=16*7;
WriteLn('╒═════════════════════════════════════════════════════════════════════════════╕');
WriteLn('│ Filelist description searcher 1.20, made by Bo Bendtsen +45-42643827 │');
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(List,Copy(ParamStr(0),1,Length(ParamStr(0))-3)+'CFG');
SetTextBuf(I,CfgBuf);
{$I-} Reset(List); {$I+}
If IOResult<>0 Then
Begin
WriteLn('Unable to open config file');
Halt;
End;
L:=0; Fillchar(Name,sizeof(name),0);
WriteLn('Reading files '+Paramstr(1));
FindFirst(Paramstr(1),Archive,Info);
While (DosError=0) And (L<MaxFiles) 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');
SetTextBuf(I,OutBuf);
{$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');
New(Buf);
While Not Eof(List) And Not Keypressed Do
Begin
ReadLn(List,S);
ReadNext:=True;
If (S<>'') And Not (S[1] in [';','%']) Then
Begin
WriteLn(GrabWord(s,1));
StartPos:=StrToInt(GrabWord(s,2)); If StartPos=0 Then StartPos:=1;
DescPos:=StrToInt(GrabWord(s,3)); If DescPos=0 Then DescPos:=1;
Assign(I,GrabWord(s,1));
SetTextBuf(I,Buf^);
{$I-} Reset(I); {$I+}
If IOResult<>0 Then WriteLn('Unable to open input file')
Else Begin
WriteLn(Out);
WriteLn(Out,' - MakeBBS : '+GrabWord(s,1));
WriteLn(Out);
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;
If ReadNext Then ReadLn(I,S);
ReadNext:=True;
If S<>'' Then
Begin
UPS:=StUpcase(S);
For x:=1 To L Do
Begin
If Pos(Name[x],UPS)=StartPos Then
Begin
Dec(Left);
WriteLn(Out,BlankAfter(Name[x],13)+Copy(S,DescPos,255));
Name[x]:='';
LookForMore;
End
Else Begin
p:=Pos('.',Name[x]);
If Pos(Copy(Name[x],1,p),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],13)+Copy(S,DescPos,255));
Name[x]:='';
LookForMore;
End
End;
End;
End;
End;
Write(#13,'Lines: ',C,', missing ',Left,' ');
WriteLn(#13#10'Lines processed: ',C);
Close(I);
End;
End;
End;
Dispose(Buf);
If KeyPressed Then WriteLn(#13#10#10'Keyboard abort');
Close(List);
Close(Out);
End.