home *** CD-ROM | disk | FTP | other *** search
/ norge.freeshell.org (192.94.73.8) / 192.94.73.8.tar / 192.94.73.8 / pub / computers / pcjr / arc / ZZAP62A.LZH / QFIX.ZIP / QFIX.PAS < prev   
Pascal/Delphi Source File  |  1990-09-09  |  9KB  |  312 lines
  1. Program QFix;  { version 2.2 }
  2.  
  3. { This source code is provided as a sample of how to use the fixup list }
  4. { to change the BBS's download file list.  This program works with      }
  5. { QuickBBS and 4DOS, it may work with others.                           }
  6.  
  7. { Permission is hereby granted to modify this program to work with      }
  8. { other BBS list formats.  Please send me a copy (with docs) so that    }
  9. { I may add it to the ZZAP package.  Proper acknowledgements will be    }
  10. { provided in the ZZAP documents for all used submissions.              }
  11.  
  12. Uses
  13.   Crt,
  14.   Dos,
  15.   TpString;  { This is from Turbo Professional 5.0, Turbo Power Software}
  16.              { Since I can't include a copy of this unit you will have  }
  17.              { to provide your own or replace all of the routines from  }
  18.              { this unit.  The string manipulation routines I used from }
  19.              { this package should be fairly easy to duplicate.         }
  20.  
  21. { Routines used from TpString:                                              }
  22. {                                                                           }
  23. { Function AddBackSlash(Path : String);                                     }
  24. {   - Adds a backslash to the path if required.                             }
  25. {                                                                           }
  26. { Function ForceExtension(Name,Ext : String) : String;                      }
  27. {   - Forces the specified extension onto the file name.                    }
  28. {                                                                           }
  29. { Function JustFilename(PathName : String);                                 }
  30. {    - Return just the filename and extension of a pathname.                }
  31. {                                                                           }
  32. { Function Pad(S : String,Count : Integer);                                 }
  33. {    - right pads the string with spaces to make it count characters long.  }
  34. {                                                                           }
  35. { Function StUpCase(S : String) : String;                                   }
  36. {    - Convert lower case letters to uppercase.                             }
  37. {                                                                           }
  38. { Function JustPathName(Pathname : String) : String;                        }
  39. {    - Return just the drive and directory portion of a pathname.           }
  40.  
  41. Type
  42.   String12 = String[12];
  43.   StringPtr = ^String;
  44.   ListPtr = ^ListRec;
  45.   ListRec = Record
  46.               OldName : String12;
  47.               NewName : String12;
  48.               Next    : ListPtr;
  49.             End;
  50.  
  51. Const
  52.   SourceName : String12 = 'FILES.BBS';
  53.   SpreadIt   : Boolean = False;
  54.  
  55. Var
  56.   FixList  : Text;
  57.   Line     : String;
  58.   BufLine  : String;   { holds the next line from the list file }
  59.   FileName : String;
  60.   LastPath : String;
  61.   ListName : String;
  62.   OldName  : String;
  63.   NewName  : String;
  64.   HeapTop  : ^BYTE;
  65.   First    : ListPtr;
  66.   Current  : ListPtr;
  67.   OldExit  : Pointer;
  68.  
  69. FUNCTION MessagePtr(ErrorCode : BYTE) : StringPtr; EXTERNAL; {$L zzaperr.obj}
  70.  
  71. PROCEDURE DisplayError(ErrorCode : BYTE;Address : POINTER);
  72.  
  73. { display an error message and halt }
  74.  
  75. TYPE
  76.   PtrRec = RECORD
  77.              Low  : WORD;
  78.              High : WORD;
  79.            END;
  80.  
  81. VAR
  82.   LinePtr : StringPtr;
  83.  
  84. BEGIN
  85.   WRITE('ERROR #',ErrorCode,':  ');
  86.   LinePtr := MessagePtr(ErrorCode);
  87.   IF LinePtr <> NIL
  88.     THEN WRITE(LinePtr^)
  89.   ELSE WRITE('Unknown error code');
  90.   WRITE(' at ',HexW(PtrRec(Address).High),':',HexW(PtrRec(Address).Low));
  91. End;
  92.  
  93. {$F+}
  94. Procedure MyExit;
  95. {$F-}
  96. BEGIN
  97.   If ErrorAddr <> NIL THEN
  98.   BEGIN
  99.     DisplayError(ExitCode,ErrorAddr);
  100.     EXITCODE := 0;
  101.     ERRORADDR := NIL;
  102.   END;
  103. END;
  104.  
  105. Procedure ReadLine(Var Source : Text;Var Line : String);
  106.  
  107. {-Returns the buffered line (BUFLINE) if not empty, otherwise }
  108. { reads a line directly from the file.                        }
  109.  
  110. Begin
  111.   If BufLine = ''
  112.     Then ReadLn(Line)
  113.   Else Begin
  114.     Line := BufLine;
  115.     BufLine := '';
  116.   End;
  117. End;
  118.  
  119. Function PeekLine(Var Source : Text) : String;
  120.  
  121. {-Returns a line of text, the line is buffered so that it will }
  122. { be returned by the next use of READLINE.                     }
  123.  
  124. Begin
  125.   If BufLine = '' Then ReadLn(Source,BufLine);
  126.   PeekLine := BufLine;
  127. End;
  128.  
  129. Function EndOfFile(Var Source : Text) : Boolean;
  130.  
  131. {-Returns TRUE if at the end of the file AND the buffered line is empty. }
  132.  
  133. Begin
  134.   EndOfFile := Eof(Source) And (BufLine = '');
  135. End;
  136.  
  137. Function ExtractWord(N : Byte;S : String) : String;
  138.  
  139. Var
  140.   Line  : String;
  141.   CL    : ^String;
  142.  
  143. Begin
  144.   CL := Ptr(PrefixSeg,$0080);
  145.   Line := CL^;
  146.   CL^ := S;
  147.   ExtractWord := ParamStr(N);
  148.   CL^ := Line;
  149. End;
  150.  
  151. Procedure ProcessList(First : ListPtr;Path : String);
  152.  
  153. {-Processes the list of files in the given subdirectory. }
  154.  
  155. Var
  156.   Current : ListPtr;
  157.   Source   : Text;
  158.   Target   : Text;
  159.   Dummy    : File;
  160.   Line     : String;
  161.   FileName : String;
  162.   Name     : String12;
  163.   Attr     : Word;
  164.   X        : Integer;
  165.  
  166. Begin
  167.   FileName := AddBackSlash(Path) + SourceName;
  168.   Assign(Source,FileName);
  169.   GetFAttr(Source,Attr);
  170.   If (DosError <> 0) OR (Attr AND (SysFile OR ReadOnly) <> 0) Then Exit;
  171.   SetFAttr(Source,Attr AND $3C);
  172.   Reset(Source);
  173.   Assign(Target,ForceExtension(FileName,'$$$'));
  174.   Rewrite(Target);
  175.   Write(Path,'  ');
  176.   X := WhereX;
  177.   While Not Eof(Source) Do
  178.   Begin
  179.     ReadLn(Source,Line);       { get a line from the BBS list             }
  180.     If Pos(' ',Line) > 1 Then  { if a blank is in the first position then }
  181.     Begin                      { it can't be a file name, perhaps part of }
  182.                                { a multiline description or a null line   }
  183.       Current := First;
  184.       While Current <> NIL Do
  185.       Begin
  186.         If Pos(Current^.OldName,StUpCase(Line)) = 1
  187.           Then Begin
  188.             GotoXY(X,WhereY);
  189.             ClrEol;
  190.             Write(Current^.OldName,' ==> ',Current^.NewName);
  191.             Line := Pad(Current^.NewName,12) + Copy(Line,13,255);
  192.             Current := Nil;                   { force us out of the loop }
  193.           End
  194.         Else Current := Current^.Next;
  195.       End;
  196.     End;
  197.     WriteLn(Target,Line);
  198.   End;
  199.   Write(^M);
  200.   ClrEol;
  201.   Close(Source);
  202.   Close(Target);
  203.   Assign(Dummy,ForceExtension(FileName,'BAK'));
  204.   {$I-}
  205.   Erase(Dummy);
  206.   {$I+}
  207.   If IOResult = 0 Then {} ;
  208.   Rename(Source,ForceExtension(FileName,'BAK'));
  209.   Rename(Target,FileName);
  210.   SetFAttr(Target,Attr);
  211. End;
  212.  
  213. Procedure ProcessSwitches;
  214.  
  215. Var
  216.   CL : ^STRING;
  217.  
  218. Begin
  219.   CL := Ptr(PrefixSeg,$0080);
  220.   CL^ := StUpCase(CL^);
  221.   If Pos('/S',CL^) > 0 THEN
  222.   BEGIN
  223.     SpreadIt := TRUE;
  224.     Delete(CL^,Pos('/S',CL^),2);
  225.   END;
  226. End;
  227.  
  228. Function Spread(Var FileName : String) : String;
  229.  
  230. Var
  231.   Path,Name,Ext : String;
  232.  
  233. Begin
  234.   FSplit(FileName,Path,Name,Ext);
  235.   Spread := Pad(Name,8) + Ext;
  236. End;
  237.  
  238. Begin { main }
  239.   WriteLn('QFIX Version 2.2');
  240.   OldExit := ExitProc;
  241.   ExitProc := @MyExit;
  242.   ProcessSwitches;
  243.   If ParamCount > 0 Then SourceName := JustFilename(ParamStr(1));
  244.   ListName := FSearch('FILES.FIX',GetEnv('PATH'));
  245.   If ListName = '' Then
  246.   Begin
  247.     WriteLn('List file, FILES.FIX, not found.');
  248.     Halt(1);
  249.   End;
  250.   Assign(FixList,ListName);
  251.   {$I-}
  252.   Reset(FixList);
  253.   {$I+}
  254.   If IOResult <> 0 Then Halt;
  255.   BufLine := '';
  256.   LastPath := JustPathName(PeekLine(FixList));
  257.   While Not EndOfFile(FixList) Do
  258.   Begin
  259.     First := Nil;
  260.     Mark(HeapTop);
  261.     While (LastPath = JustPathName(PeekLine(FixList))) AND (NOT EndOfFile(FixList)) DO
  262.     Begin
  263.  
  264. { If the next path to read is the same as the current path then add the }
  265. { file names to the linked list.                                        }
  266.  
  267.       If JustPathName(ExtractWord(1,PeekLine(FixList))) = LastPath
  268.       Then Begin  { if the same path as the previous file }
  269.  
  270.         ReadLine(FixList,Line);  { get the next line }
  271.         OldName := JustFileName(ExtractWord(1,Line));
  272.         NewName := ExtractWord(2,Line);
  273.         If OldName <> NewName Then    { only care about file names that change }
  274.         Begin                         { delete this test if you must touch up  }
  275.                                       { entries even if the file name hasn't   }
  276.                                       { changes.                               }
  277.           If First = NIL    { add the file name to the linked list }
  278.             Then Begin
  279.               New(First);
  280.               Current := First;
  281.             End
  282.           Else Begin
  283.             New(Current^.Next);
  284.             Current := Current^.Next;
  285.           End;
  286.           If SpreadIt
  287.             Then Begin
  288.               Current^.OldName := Spread(OldName);
  289.               Current^.NewName := Spread(NewName);
  290.             End
  291.           Else Begin
  292.             Current^.OldName := OldName;
  293.             Current^.NewName := NewName;
  294.           END;
  295.           Current^.Next := Nil;
  296.         End;
  297.       End;
  298.     End;
  299. { Go fix up the BBS list for the current subdirectory }
  300.  
  301.     If First <> NIL Then ProcessList(First,LastPath); { process the list }
  302.  
  303.  
  304. { the next path is now the current path }
  305.  
  306.     LastPath := JustPathName(PeekLine(FixList));
  307.     Release(HeapTop);
  308.   End;
  309.   Close(FixList);   { close the fix list }
  310.   Erase(FixList);   { .. and erase it    }
  311. End.
  312.