Programmer 7500/MAX_PROGRAMMERS.iso/PROGRAMS/UTILS/COMPRESS/ZZAP61A.ZIP/QFIX.ZIP/QFIX.PAS

Pascal/Delphi Source File | 1990-09-09 | 9.3 KB | 312 lines

Program QFix;  { version 2.2 }

{ This source code is provided as a sample of how to use the fixup list }
{ to change the BBS's download file list.  This program works with      }
{ QuickBBS and 4DOS, it may work with others.                           }

{ Permission is hereby granted to modify this program to work with      }
{ other BBS list formats.  Please send me a copy (with docs) so that    }
{ I may add it to the ZZAP package.  Proper acknowledgements will be    }
{ provided in the ZZAP documents for all used submissions.              }

Uses
  Crt,
  Dos,
  TpString;  { This is from Turbo Professional 5.0, Turbo Power Software}
             { Since I can't include a copy of this unit you will have  }
             { to provide your own or replace all of the routines from  }
             { this unit.  The string manipulation routines I used from }
             { this package should be fairly easy to duplicate.         }

{ Routines used from TpString:                                              }
{                                                                           }
{ Function AddBackSlash(Path : String);                                     }
{   - Adds a backslash to the path if required.                             }
{                                                                           }
{ Function ForceExtension(Name,Ext : String) : String;                      }
{   - Forces the specified extension onto the file name.                    }
{                                                                           }
{ Function JustFilename(PathName : String);                                 }
{    - Return just the filename and extension of a pathname.                }
{                                                                           }
{ Function Pad(S : String,Count : Integer);                                 }
{    - right pads the string with spaces to make it count characters long.  }
{                                                                           }
{ Function StUpCase(S : String) : String;                                   }
{    - Convert lower case letters to uppercase.                             }
{                                                                           }
{ Function JustPathName(Pathname : String) : String;                        }
{    - Return just the drive and directory portion of a pathname.           }

Type
  String12 = String[12];
  StringPtr = ^String;
  ListPtr = ^ListRec;
  ListRec = Record
              OldName : String12;
              NewName : String12;
              Next    : ListPtr;
            End;

Const
  SourceName : String12 = 'FILES.BBS';
  SpreadIt   : Boolean = False;

Var
  FixList  : Text;
  Line     : String;
  BufLine  : String;   { holds the next line from the list file }
  FileName : String;
  LastPath : String;
  ListName : String;
  OldName  : String;
  NewName  : String;
  HeapTop  : ^BYTE;
  First    : ListPtr;
  Current  : ListPtr;
  OldExit  : Pointer;

FUNCTION MessagePtr(ErrorCode : BYTE) : StringPtr; EXTERNAL; {$L zzaperr.obj}

PROCEDURE DisplayError(ErrorCode : BYTE;Address : POINTER);

{ display an error message and halt }

TYPE
  PtrRec = RECORD
             Low  : WORD;
             High : WORD;
           END;

VAR
  LinePtr : StringPtr;

BEGIN
  WRITE('ERROR #',ErrorCode,':  ');
  LinePtr := MessagePtr(ErrorCode);
  IF LinePtr <> NIL
    THEN WRITE(LinePtr^)
  ELSE WRITE('Unknown error code');
  WRITE(' at ',HexW(PtrRec(Address).High),':',HexW(PtrRec(Address).Low));
End;

{$F+}
Procedure MyExit;
{$F-}
BEGIN
  If ErrorAddr <> NIL THEN
  BEGIN
    DisplayError(ExitCode,ErrorAddr);
    EXITCODE := 0;
    ERRORADDR := NIL;
  END;
END;

Procedure ReadLine(Var Source : Text;Var Line : String);

{-Returns the buffered line (BUFLINE) if not empty, otherwise }
{ reads a line directly from the file.                        }

Begin
  If BufLine = ''
    Then ReadLn(Line)
  Else Begin
    Line := BufLine;
    BufLine := '';
  End;
End;

Function PeekLine(Var Source : Text) : String;

{-Returns a line of text, the line is buffered so that it will }
{ be returned by the next use of READLINE.                     }

Begin
  If BufLine = '' Then ReadLn(Source,BufLine);
  PeekLine := BufLine;
End;

Function EndOfFile(Var Source : Text) : Boolean;

{-Returns TRUE if at the end of the file AND the buffered line is empty. }

Begin
  EndOfFile := Eof(Source) And (BufLine = '');
End;

Function ExtractWord(N : Byte;S : String) : String;

Var
  Line  : String;
  CL    : ^String;

Begin
  CL := Ptr(PrefixSeg,$0080);
  Line := CL^;
  CL^ := S;
  ExtractWord := ParamStr(N);
  CL^ := Line;
End;

Procedure ProcessList(First : ListPtr;Path : String);

{-Processes the list of files in the given subdirectory. }

Var
  Current : ListPtr;
  Source   : Text;
  Target   : Text;
  Dummy    : File;
  Line     : String;
  FileName : String;
  Name     : String12;
  Attr     : Word;
  X        : Integer;

Begin
  FileName := AddBackSlash(Path) + SourceName;
  Assign(Source,FileName);
  GetFAttr(Source,Attr);
  If (DosError <> 0) OR (Attr AND (SysFile OR ReadOnly) <> 0) Then Exit;
  SetFAttr(Source,Attr AND $3C);
  Reset(Source);
  Assign(Target,ForceExtension(FileName,'$$$'));
  Rewrite(Target);
  Write(Path,'  ');
  X := WhereX;
  While Not Eof(Source) Do
  Begin
    ReadLn(Source,Line);       { get a line from the BBS list             }
    If Pos(' ',Line) > 1 Then  { if a blank is in the first position then }
    Begin                      { it can't be a file name, perhaps part of }
                               { a multiline description or a null line   }
      Current := First;
      While Current <> NIL Do
      Begin
        If Pos(Current^.OldName,StUpCase(Line)) = 1
          Then Begin
            GotoXY(X,WhereY);
            ClrEol;
            Write(Current^.OldName,' ==> ',Current^.NewName);
            Line := Pad(Current^.NewName,12) + Copy(Line,13,255);
            Current := Nil;                   { force us out of the loop }
          End
        Else Current := Current^.Next;
      End;
    End;
    WriteLn(Target,Line);
  End;
  Write(^M);
  ClrEol;
  Close(Source);
  Close(Target);
  Assign(Dummy,ForceExtension(FileName,'BAK'));
  {$I-}
  Erase(Dummy);
  {$I+}
  If IOResult = 0 Then {} ;
  Rename(Source,ForceExtension(FileName,'BAK'));
  Rename(Target,FileName);
  SetFAttr(Target,Attr);
End;

Procedure ProcessSwitches;

Var
  CL : ^STRING;

Begin
  CL := Ptr(PrefixSeg,$0080);
  CL^ := StUpCase(CL^);
  If Pos('/S',CL^) > 0 THEN
  BEGIN
    SpreadIt := TRUE;
    Delete(CL^,Pos('/S',CL^),2);
  END;
End;

Function Spread(Var FileName : String) : String;

Var
  Path,Name,Ext : String;

Begin
  FSplit(FileName,Path,Name,Ext);
  Spread := Pad(Name,8) + Ext;
End;

Begin { main }
  WriteLn('QFIX Version 2.2');
  OldExit := ExitProc;
  ExitProc := @MyExit;
  ProcessSwitches;
  If ParamCount > 0 Then SourceName := JustFilename(ParamStr(1));
  ListName := FSearch('FILES.FIX',GetEnv('PATH'));
  If ListName = '' Then
  Begin
    WriteLn('List file, FILES.FIX, not found.');
    Halt(1);
  End;
  Assign(FixList,ListName);
  {$I-}
  Reset(FixList);
  {$I+}
  If IOResult <> 0 Then Halt;
  BufLine := '';
  LastPath := JustPathName(PeekLine(FixList));
  While Not EndOfFile(FixList) Do
  Begin
    First := Nil;
    Mark(HeapTop);
    While (LastPath = JustPathName(PeekLine(FixList))) AND (NOT EndOfFile(FixList)) DO
    Begin

{ If the next path to read is the same as the current path then add the }
{ file names to the linked list.                                        }

      If JustPathName(ExtractWord(1,PeekLine(FixList))) = LastPath
      Then Begin  { if the same path as the previous file }

        ReadLine(FixList,Line);  { get the next line }
        OldName := JustFileName(ExtractWord(1,Line));
        NewName := ExtractWord(2,Line);
        If OldName <> NewName Then    { only care about file names that change }
        Begin                         { delete this test if you must touch up  }
                                      { entries even if the file name hasn't   }
                                      { changes.                               }
          If First = NIL    { add the file name to the linked list }
            Then Begin
              New(First);
              Current := First;
            End
          Else Begin
            New(Current^.Next);
            Current := Current^.Next;
          End;
          If SpreadIt
            Then Begin
              Current^.OldName := Spread(OldName);
              Current^.NewName := Spread(NewName);
            End
          Else Begin
            Current^.OldName := OldName;
            Current^.NewName := NewName;
          END;
          Current^.Next := Nil;
        End;
      End;
    End;
{ Go fix up the BBS list for the current subdirectory }

    If First <> NIL Then ProcessList(First,LastPath); { process the list }


{ the next path is now the current path }

    LastPath := JustPathName(PeekLine(FixList));
    Release(HeapTop);
  End;
  Close(FixList);   { close the fix list }
  Erase(FixList);   { .. and erase it    }
End.