home *** CD-ROM | disk | FTP | other *** search
/ BBS in a Box 3 / BBS in a box - Trilogy III.iso / Files / Tele / Pete Johnson / Copy Cat 1.02 source Folder / Copy Cat.p < prev    next >
Encoding:
Text File  |  1991-09-08  |  6.9 KB  |  238 lines  |  [TEXT/PJMM]
  1. program CopyCat;
  2.  
  3.     const
  4.         ENDLINE = chr(13);
  5.         MaxChars = 10240;
  6.         sleep = 10;
  7.  
  8.     type
  9.         BufType = packed array[1..MaxChars] of char;
  10.         BufPtr = ^BufType;
  11.         BufHdl = ^BufPtr;
  12.  
  13.     var
  14.         iType: integer;
  15.         iHandle: handle;
  16.         iBox: rect;
  17.         err: OSErr;
  18.         volName, inputName, outputName: str255;
  19.         vRefNum, scriptRef, inputRef, outputRef: integer;
  20.         charsToTransfer: longint;
  21.         myBuffer: BufHdl;
  22.         IgnoreBool: boolean;                {    These variables for WaitNextEvent calls    }
  23.         AnEventRec: EventRecord;
  24.  
  25. {-----------------------------------------------------------------    }
  26.  
  27.     function GetFileName (Input: str255): str255;
  28.  
  29.     begin
  30.         while (pos(':', Input) > 0) & (length(Input) > 1) do
  31.             Input := copy(Input, pos(':', Input) + 1, 255);
  32.         GetFileName := Input
  33.     end;
  34.  
  35. {-----------------------------------------------------------------    }
  36.  
  37.     var
  38.         theDialog: DialogPtr;
  39.         oldPort: grafPtr;
  40.  
  41.     procedure OpenDialog;
  42.  
  43.     begin
  44.         GetPort(oldPort);
  45.         theDialog := GetNewDialog(501, nil, Pointer(-1));
  46.         DrawDialog(theDialog);
  47.         SetPort(theDialog);
  48.         ForeColor(RedColor);
  49.         getDItem(theDialog, 2, iType, iHandle, iBox);
  50.         SetIText(iHandle, 'CopyCat');
  51.         ForeColor(BlueColor);
  52.     end;
  53.  
  54. {-----------------------------------------------------------------    }
  55.  
  56.     procedure CloseDialog;
  57.  
  58.     begin
  59.         DisposDialog(theDialog);
  60.         SetPort(oldPort);
  61.     end;
  62.  
  63. {-----------------------------------------------------------------    }
  64.  
  65.     function AtEOF (fRefNum: Integer): Boolean;
  66.  
  67.         var
  68.             Err: OSErr;
  69.             currPos, eofPos: LongInt;
  70.  
  71.     begin
  72.         Err := GetFPos(fRefNum, currPos);
  73.         Err := GetEOF(fRefNum, eofPos);
  74.         AtEOF := currPos = eofPos
  75.     end;
  76.  
  77. {-----------------------------------------------------------------    }
  78.  
  79.     function ReadALine (FileRefNum: integer; var TheMessage: string): OSErr;
  80.  
  81.         var
  82.             myPB: ParamBlockRec;
  83.             myString: Str255;
  84.  
  85.     begin
  86.         myString := '';
  87.         myPB.ioCompletion := nil;
  88.         myPB.ioRefNum := FileRefNum;
  89.         myPB.ioBuffer := Pointer(@myString[1]);
  90.         myPB.ioReqCount := 255;
  91.         myPB.ioPosMode := 3456; {ASCII 13*256+128}
  92.         myPB.ioPosOffset := 0; {ignored}
  93.         ReadALine := PBRead(@myPB, False);
  94.         if (myString[myPB.ioActCount] = chr(13)) then
  95.             myString[0] := char(myPB.ioActCount - 1) {Drop CR}
  96.         else
  97.             myString[0] := char(myPB.ioActCount);
  98.         TheMessage := myString
  99.     end;
  100.  
  101. {-----------------------------------------------------------------    }
  102.  
  103.     function Wr (FileRefNum: integer; TheMessage: string): OSErr;
  104.  
  105. {    Writes string (without length byte) to text file, returns error code    }
  106.  
  107.         var
  108.             TheLength: longint;
  109.  
  110.     begin
  111.         TheLength := length(TheMessage);
  112.         Wr := FSWrite(FileRefNum, TheLength, Pointer(ord(@TheMessage) + 1));
  113.     end;
  114.  
  115. {-----------------------------------------------------------------    }
  116.  
  117.     function WrLn (FileRefNum: integer; TheMessage: string): OSErr;
  118.  
  119. {    Writes string (without length byte) to text file, returns error code    }
  120.  
  121.     begin
  122.         TheMessage := concat(TheMessage, ENDLINE);
  123.         WrLn := Wr(FileRefNum, TheMessage);
  124.     end;
  125.  
  126. {-----------------------------------------------------------------    }
  127.  
  128.     function CheckFileName (var FileName: str255): boolean;
  129.  
  130. {    returns true if FileName ends in ' [-]' and strips those characters,    }
  131. {    otherwise returns false and leaves FileName unchanged    }
  132.  
  133.     begin
  134.         CheckFileName := false;
  135.         if pos(' [-]', FileName) = length(FileName) - 3 then
  136.             begin
  137.                 FileName := copy(FileName, 1, length(FileName) - 4);
  138.                 CheckFileName := true;
  139.             end;
  140.     end;
  141.  
  142. {-----------------------------------------------------------------    }
  143.  
  144.     var
  145.         counter, inResRefNum, outResRefNum: integer;
  146.         ScriptName: str255;
  147.         deleteFile: boolean;
  148.         FileInfo: FInfo;
  149.         myPB: paramBlockRec;
  150.         ModTime, CreationTime: longint;
  151.  
  152. begin
  153.     ScriptName := GetString(501)^^;
  154.     myBuffer := BufHdl(NewHandle(sizeOf(BufType)));
  155.     err := GetVol(@volName, vRefNum);
  156.     err := FSOpen(concat(':', ScriptName), vRefNum, scriptRef);
  157.     OpenDialog;
  158.     counter := 0;
  159.     if (err = NoErr) then
  160.         while (not AtEOF(scriptRef)) do
  161.             begin
  162.                 deleteFile := false;
  163.                 if (err = NoErr) then
  164.                     err := ReadALine(scriptRef, inputName);
  165.                 deleteFile := CheckFileName(inputName);
  166.                 IgnoreBool := WaitNextEvent(EveryEvent, AnEventRec, sleep, nil);
  167.                 if (err = NoErr) then
  168.                     err := ReadALine(scriptRef, outputName);
  169.                 IgnoreBool := WaitNextEvent(EveryEvent, AnEventRec, sleep, nil);
  170.                 if (err = NoErr) then
  171.                     err := FSOpen(inputName, vRefNum, inputRef);
  172.                 if err = noErr then
  173.                     begin
  174.                         err := GetFInfo(inputName, vRefNum, FileInfo);
  175.                         myPB.ioNamePtr := @inputName;
  176.                         myPB.ioVRefNum := vRefNum;
  177.                         myPB.ioFDirIndex := 0;
  178.                         myPB.ioFVersNum := 0;
  179.                         err := PBGetFInfo(@myPB, false);
  180.                         CreationTime := myPB.ioFlCrDat;
  181.                         ModTime := myPB.ioFlMdDat;
  182.                         counter := succ(counter);
  183.                         getDItem(theDialog, 1, iType, iHandle, iBox);
  184.                         SetIText(iHandle, concat(stringOf(counter : 1), ' — ', GetFileName(inputName)));
  185.                         err := FSDelete(outputName, vRefNum);
  186.                         IgnoreBool := WaitNextEvent(EveryEvent, AnEventRec, sleep, nil);
  187.                         Err := Create(outputName, vRefNum, FileInfo.fdCreator, FileInfo.fdType);
  188.                         err := FSOpen(outputName, vRefNum, outputRef);
  189.                         HLock(handle(myBuffer));
  190.                         charsToTransfer := MaxChars;
  191.                         while (not AtEOF(inputRef)) & (err = NoErr) & (charsToTransfer = MaxChars) do
  192.                             begin
  193.                                 IgnoreBool := WaitNextEvent(EveryEvent, AnEventRec, sleep, nil);
  194.                                 err := FSRead(inputRef, charsToTransfer, Ptr(myBuffer^));
  195.                                 IgnoreBool := WaitNextEvent(EveryEvent, AnEventRec, sleep, nil);
  196.                                 err := FSWrite(outputRef, charsToTransfer, Ptr(myBuffer^));
  197.                                 IgnoreBool := WaitNextEvent(EveryEvent, AnEventRec, sleep, nil)
  198.                             end;
  199.                         HUnLock(handle(myBuffer));
  200.                         err := FSClose(outputRef);
  201.                         err := FSClose(inputRef);
  202.                         err := OpenRF(inputName, vRefNum, inResRefNum);
  203.                         if err = noErr then
  204.                             begin
  205.                                 HLock(handle(myBuffer));
  206.                                 charsToTransfer := MaxChars;
  207.                                 err := OpenRF(outputName, vRefNum, outResRefNum);
  208.                                 while (not AtEOF(inResRefNum)) & (err = NoErr) & (charsToTransfer = MaxChars) do
  209.                                     begin
  210.                                         IgnoreBool := WaitNextEvent(EveryEvent, AnEventRec, sleep, nil);
  211.                                         err := FSRead(inResRefNum, charsToTransfer, Ptr(myBuffer^));
  212.                                         IgnoreBool := WaitNextEvent(EveryEvent, AnEventRec, sleep, nil);
  213.                                         err := FSWrite(outResRefNum, charsToTransfer, Ptr(myBuffer^));
  214.                                         IgnoreBool := WaitNextEvent(EveryEvent, AnEventRec, sleep, nil)
  215.                                     end;
  216.                                 HUnLock(handle(myBuffer));
  217.                                 err := FSClose(outResRefNum);
  218.                                 myPB.ioNamePtr := @outputName;
  219.                                 myPB.ioVRefNum := vRefNum;
  220.                                 myPB.ioFDirIndex := 0;
  221.                                 myPB.ioFVersNum := 0;
  222.                                 err := PBGetFInfo(@myPB, false);
  223.                                 myPB.ioFlCrDat := CreationTime;
  224.                                 myPB.ioFlMdDat := ModTime;
  225.                                 err := PBSetFInfo(@myPB, false);
  226.                             end;
  227.                         err := FSClose(inResRefNum);
  228.                         if deleteFile then
  229.                             while err = noErr do
  230.                                 err := FSDelete(inputName, vRefNum);
  231.                     end;    {no error on input file}
  232.                 IgnoreBool := WaitNextEvent(EveryEvent, AnEventRec, sleep, nil)
  233.             end;
  234.     err := FSClose(scriptRef);
  235.     CloseDialog;
  236.     if myBuffer <> nil then
  237.         DisposHandle(Handle(myBuffer))
  238. end.