Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/LCU.ZIP/FILEFCNS.PAS

Pascal/Delphi Source File | 1993-01-04 | 7.1 KB | 303 lines

{$R-}    {Range checking off}
{$B-}    {Boolean complete evaluation off}
{$S-}    {Stack checking off}
{$N-}    {No numeric coprocessor}
{$I-}    {IO Checking Off}
{$D+}
{$T+}

unit FileFcns;
{JW Sparks, last revised 06/30/88}

interface
uses Crt, Dos, Colors, ErrProcs, MemComp;

Const
   MaxFileBufSize = $FE00;

Function  FileComp(SourceName,DestName:String; var ErrorNumber: Integer): Boolean;

Procedure FileCopy(SourceName,DestName:String; var ErrorNumber: Integer);

Function GetCopyBufferSize: LongInt;

Function GetCompareBufferSize: LongInt;

{-----}

Implementation

{***}

Function GetCompareBufferSize: LongInt;
begin
{Need to set up two buffers for compare}
If ( (MaxAvail - 32) > (2 * MaxFileBufSize) ) then
        GetCompareBufferSize := MaxFileBufSize
   else GetCompareBufferSize := (MaxAvail - 32) div 2;

end;

{***}

Function GetCopyBufferSize: LongInt;
begin
{Need to set up one buffer for copy}
If ( (MaxAvail - 16) >  MaxFileBufSize ) then
        GetCopyBufferSize := MaxFileBufSize
   else GetCopyBufferSize := MaxAvail - 16;
end;

{***}

Function FileComp(SourceName,DestName:String; var ErrorNumber: Integer): Boolean;
{Compares two Files, returns TRUE if identical}
Type
   FileBufPtr       = ^FileBuffer;
   FileBuffer       = record
                     ByteArray : array[1..MaxFileBufSize] of Byte;
                  end;
var
   SourceBufPtr : FileBufPtr;
   DestBufPtr   : FileBufPtr;
   BufSize      : LongInt;

   Source, Dest : File;
   SourceSize   : LongInt;
   DestSize     : LongInt;

   BytesThisCycle : word;
   W              : word;

   MemoryAvailable: LongInt;
   BytesSoFar     : LongInt;
   Compare        : Boolean;

Begin
FileComp := FALSE;

FileMode := 0;
Assign(Source, SourceName);
Reset(Source, 1);
IOCheck(ErrorNumber, [1..255]);
FileMode := 2;
if (IOErr=True) then
   begin
   close(Source);
   Exit;
   end;
SourceSize := FileSize(Source);

FileMode := 0;
Assign(Dest,DestName);
Reset(Dest, 1);
IOCheck(ErrorNumber, [1..255]);

FileMode := 2;
if (IOErr=TRUE) then
   begin
   close(Source);
   close(Dest);
   Exit;
   end;
DestSize := FileSize(Dest);

WriteLn('Comparing ',SourceName,' (', SourceSize, ' bytes)');
WriteLn('     with ',DestName, ' (', DestSize, ' bytes)' );

If SourceSize <> DestSize then begin
   TextColor(Emphasized);
   Writeln('File Lengths are DIFFERENT');
   TextColor(Foreground);
   close(Source);
   close(Dest);
   exit;
   end;

BufSize := GetCompareBufferSize;
GetMem(SourceBufPtr, BufSize);
GetMem(DestBufPtr,   BufSize);
BytesSoFar := 0;

Repeat
   BytesThisCycle := BufSize;
   BlockRead(Source, SourceBufPtr^, BufSize, BytesThisCycle);
   BlockRead(Dest  , DestBufPtr^  , BufSize, BytesThisCycle);
   W := CompMem(SourceBufPtr^, DestBufPtr^, BytesThisCycle);

   if (W = 0) then
      begin
         Compare := TRUE;
         BytesSoFar := BytesSoFar + BytesThisCycle;
      end
    else
       begin
          Compare := FALSE;
          BytesSoFar := BytesSoFar + W;
          TextColor(Warning);
          WriteLn('Compare Error at postition ', BytesSoFar, ' bytes');
          TextColor(Foreground);
       end;
until ( (Compare=False) or (EOF(Source)) );

close(Source);
close(Dest);

FreeMem(SourceBufPtr, BufSize);
FreeMem(DestBufPtr,   BufSize);
FileComp := Compare;

end;

{***}

Procedure FileCopy(SourceName,DestName:String; var ErrorNumber: Integer);
{Copies File: SourceName to DestName; returns ErrorNumber := 0 if successful,
 Returns ErrorNumber=200 if not enough space on destination drive
         ErrorNumber=210 if FileCopy aborted}

Const
   MaxFileBufSize   = $FE00;
Type
   FileBufPtr       = ^FileBuffer;
   FileBuffer       =  record
                     ByteArray : array[1..MaxFileBufSize] of Byte;
                   end;
Var

   MemoryAvailable : longInt;

   InBufPtr     : FileBufPtr;
   Source, Dest : File;
   SourceSize   : longint;
   FileTimeDate : LongInt;
   DiskNum      : Word;
   Attribute    : word;

   BufSize         : Word;
   BytesThisCycle  : Word;
   C               : Char;
   NewPathName     : String;

Begin
ErrorNumber := 0;

FileMode := 0;
Assign(Source, SourceName);
Reset(Source, 1);
IOCheck(ErrorNumber, [1..255]);
FileMode := 2;
if (IOErr=TRUE) then
   begin
   Close(Source);
   Exit;
   end;
SourceSize := FileSize(Source);

FileMode := 2;
Assign(Dest,DestName);
GetFAttr(Dest, Attribute);
if DosError=3 then
   begin
      NewPathName := '';
      while pos('\', DestName)>0 do begin
         NewPathName := NewPathName + copy(DestName, 1, pos('\', DestName) );
         Delete(DestName, 1, Pos('\', DestName) );
         end;
      TextColor(Warning);
      WriteLn(#7, 'Path Does Not Exist: ', NewPathName);
      Write('Would You Like to Create it? ');
      C := ReadKey;
      C := upcase(C);
      WriteLn(C);
      If C = 'Y' then {Create new directory on destination disk}
         begin
            Delete(NewPathName, length(NewPathName), 1);
            MkDir(NewPathName);
            IOCheck(ErrorNumber, [1..255]);
            DestName := NewPathName + '\' + DestName;
            if IOErr=FALSE then
               WriteLn('New Subdirectory created: ', NewPathName)
            else
               begin
                  WriteLn('Unable to Create Subdirectory: ', NewPathName);
                  TextColor(ForeGround);
                  Close(Source);
                  exit;
               end;
         end
      else
         begin
               TextColor(ForeGround);
               ErrorNumber := 210;
               Close(Source);
               exit;
         end;
   end; {DosError=3}

if ( (Attribute and ReadOnly) > 0 ) then
   begin
      TextColor(Warning);
      WriteLn(#7, 'Destination File Exists, and is Read Only : ', DestName);
      Write(#7, 'Would You Like to Overwrite (Delete) it? ');
      C := ReadKey;
      C := upcase(C);
      WriteLn(C);
      If C = 'Y' then SetFAttr(Dest,0)
      else
         begin
            TextColor(ForeGround);
            Close(Source);
            ErrorNumber := 210;
            exit;
         end;
end; {if readonly}

TextColor(Foreground);
Erase(Dest);
IOCheck(ErrorNumber, [1..255]-[2,18]);

if DestName[2]=':' then
   DiskNum := ord(upcase(DestName[1]))-64
else DiskNum := 0;

if (SourceSize > DiskFree(DiskNum) ) then
   begin
      ErrorNumber := 200;
      close(Source);
      exit;
   end;

ReWrite(Dest, 1);
IOCheck(ErrorNumber, [1..255]-[2, 18]);

if (IOErr=TRUE) then
   begin
   close(Source);
   close(Dest);
   exit;
   end;

BufSize := GetCopyBufferSize;
GetMem(InBufPtr, BufSize);
BytesThisCycle := BufSize;

WriteLn('Copying:  ',SourceName, ' (',SourceSize,' bytes)');
Write(' ----->>  ',DestName);

Repeat
BlockRead (Source, InBufPtr^, BufSize, BytesThisCycle);
BlockWrite(Dest,   InBufPtr^, BytesThisCycle);
until EOF(Source);

GetFTime(Source, FileTimeDate);
SetFTime(Dest,   FileTimeDate);
close(Source);
close(Dest);
FreeMem(InBufPtr,BufSize);
end; {FileCopy}

{***}

 end. {Unit: FileFcns}