(****************************************************************)
(*                     DATABASE TOOLBOX 4.0                     *)
(*     Copyright (c) 1984, 87 by Borland International, Inc.    *)
(*                                                              *)
(*                      FileUtil Unit                           *)
(*                                                              *)
(*  A unit of general purpose routines that are related to file *)
(*  I/O and the manipulation of path/file names.                *)
(*                                                              *)
(****************************************************************)
unit FileUtil;
interface
uses DOS,
     CRT,
     MiscTool;
{ If a compiler error occurs here, you need to unpack the source
  to the MiscTool unit from the archived file Tools.arc.  See the
  README file on disk 1 for detailed instructions. }


type
  FileName = string[66];
  PathName = string[64];
  FileExt = string[4];
  FileNm  = string[8];

  FileSpec = record
               Path : PathName;
               Name : FileNm;
               Ext  : FileExt;
             end;
{ A FileSpec record is a file specifier.  It holds seperately a files
  Path or directory, the name and extension. }

procedure CopyFile(Source, Dest : FileName);
{  Copies file specified by source to the file named by Dest. }
{ This routine assumes that Source exists. }

procedure GetFileSpec(var FSP : FileSpec; FN : FileName);
{ Splits FN into Path, Name and Ext and stores these in FSP }

procedure MoveFile(Source, Dest : FileName);
{ Copies file specified by Source to Dest and if successful removes Source }

procedure Remove(FN : FileName);
{ Erases the file named by FN }

procedure Redir(var F : text; FN : FileName);
{ Redirects standard output (on the fly) to the file named by FN. }

function StripExt(var F : FileName) : FileExt;
{ Returns a file names extenstion }

function StripName(var F : FileName) : FileNm;
{ Returns a file's name i.e. no path no extension }

procedure UnRedir;
{ Removes I/O redirection sends output to the console. }

implementation

function StripExt(var F : FileName) : FileExt;
{ Returns a file names extenstion }
var
  i : integer;
  found : boolean;
  var E : FileExt;
begin
  i := Length(F);
  found := false;
  while (i > 0) and not found do
  begin
    found := F[i] = '.';
    if F[i] = '\' then
      i := 0
    else
      if not found then
        i := pred(i);
  end;
  if found and (i > 0) then
  begin
    E := Copy(F, i, succ(Length(F) - i));
    Delete(F, i, succ(Length(F) - i));
  end
  else
    E := '';
  StripExt := UpCaseStr(E);
end; { StripExt }

function StripName(var F : FileName) : FileNm;
{ Returns a file's name i.e. no path no extension }
var
  i : integer;
  found : boolean;
  Name : FileNm;
begin
  i := Length(F);
  found := false;
  while (i > 1) and not found do
  begin
    found := F[i] in ['\', '.', ':'];
    if not found then
      i := pred(i);
  end;
  if found and (i > 1) then
  begin
    Name := Copy(F, i + 1, Length(F) - i);
    Delete(F, i + 1, Length(F) - i);
  end
  else
    Name := '';
  StripName := UpCaseStr(Name);
end; { StripName }

procedure GetFileSpec(var FSP : FileSpec; FN : FileName);
{ Splits FN into Path, Name and Ext and stores these in FSP }
begin
  FillChar(FSP, SizeOf(FSP), 0);
  with FSP do
  begin
    Ext := StripExt(FN);
    Name := StripName(FN);
    if Name = '' then
    begin
      Name := UpCaseStr(FN);
      GetDir(0, Path);
      if Path[Length(Path)] <> '\' then
        Path := Path + '\';
    end
    else
      Path := UpCaseStr(FN);
  end;
end; { GetFileSpec }

procedure CopyFile(Source, Dest : FileName);
{  Copies file specified by source to the file named by Dest. }
{ This routine assumes that Source exists. }
type
  FileBuffer = array[1..65521] of byte;
var
  InFile,
  OutFile : file;
  BlocksRead,
  BlocksWritten,
  BufSize : word;
  buf : ^FileBuffer;

begin
  BufSize := SizeOf(FileBuffer);
  if BufSize > MaxAvail then
    BufSize := MaxAvail;
  GetMem(buf, BufSize);
  Assign(InFile, Source);
  Reset(Infile, 1);
  Assign(OutFile, Dest);
  Rewrite(OutFile, 1);
  repeat
    BlockRead(Infile, buf^, BufSize, BlocksRead);
    BlockWrite(OutFile, buf^, BlocksRead, BlocksWritten);
    if BlocksWritten < BlocksRead then
      Abort('Disk full trying to copying from '+ Source + ' to ' + Dest);
  until (BlocksRead < BufSize);
  FreeMem(buf, BufSize);
  Close(InFile);
  Close(OutFile);
end; { CopyFile }

procedure Remove(FN : FileName);
{ Erases the file named by FN }
var
  F : File;
begin
  Assign(F, FN);
  {$I-}
  Reset(F);
  if IOResult = 0 then
  begin
    Close(F);
    Erase(F);
  end;
  {$I+}
end; { Remove }

procedure MoveFile(Source, Dest : FileName);
{ Copies file specified by Source to Dest and if successful removes Source }
begin
  CopyFile(Source, Dest);
  Remove(Source);
end;

const
  StdOut = 1;
  DupHandle = $45;
  ForceDup  = $46;

var
  Regs : Registers;
  OldStdOut : integer;

procedure SaveStdOut;
begin
  FillChar(Regs, SizeOf(Regs), 0);
  Regs.AH := DupHandle;
  Regs.BX := StdOut;
  MSDOS(Regs);
  if Odd(Regs.Flags) then
    Abort('Error Saving StdOut');
  OldStdOut := Regs.AX;
end;

procedure Redir(var F : text; FN : FileName);
{ Redirects standard output (on the fly) to the file named by FN. }
begin
  SaveStdOut;
  Assign(F, FN);
  Rewrite(F);
  FillChar(Regs, SizeOf(Regs), 0);
  Regs.AH := ForceDup;
  Regs.BX := TextRec(F).Handle;
  Regs.CX := StdOut; { standard output }
  MSDOS(Regs);
  if odd(Regs.Flags) then
    Abort('Error forcing duplicate file handle');
end;

procedure UnRedir;
begin
  FillChar(Regs, SizeOf(Regs), 0);
  Regs.AH := ForceDup;
  Regs.BX := OldStdOut;
  Regs.CX := StdOut;
  MSDOS(Regs);
  FillChar(Regs, SizeOf(Regs), 0);
  Regs.AH := $3E;
  Regs.BX := OldStdOut;
  MSDOS(Regs);
end;

end. { FileUtil }
