[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    Unit MKFile32;   {Delphi32 Bit Only!}

    ///////////////////////////////////////////////////////////////////////////////
    // MKFile32 Coded in Part by G.E. Ozz Nixon Jr. of Warpgroup.com             //
    // ========================================================================= //
    // Original Source for DOS by Mythical Kindom's Mark May (mmay@dnaco.net)    //
    // Re-written and distributed with permission!                               //
    // See Original Copyright Notice before using any of this code!              //
    ///////////////////////////////////////////////////////////////////////////////

    Interface

    Uses
       FileCtrl,
       Forms,
       Windows,
       SysUtils;

    Const
       fmReadOnly  = 0;          {FileMode constants}
       fmWriteOnly = 1;
       fmReadWrite = 2;
       fmDenyAll   = 16;
       fmDenyWrite = 32;
       fmDenyRead  = 48;
       fmDenyNone  = 64;
       fmNoInherit = 128;

    Const
       Tries:Word    = 150;
       TryDelay:Word = 100;

    Type
       FindRec=Record
          SRec:TSearchRec;
          Dir,
          Name,
          Ext:String;
          DError:Word;
       End;

    Type
       FindObj=Object
          FI:^FindRec;
          Procedure Init;               {Initialize}
          Procedure Done;               {Done}
          Procedure FFirst(FN:String);  {Find first}
          Procedure FNext;              {Find next}
          Procedure FDone;              {Find close}
          Function  Found:Boolean;      {File was found}
          Function  GetName:String;     {Get Filename}
          Function  GetFullPath:String; {Get filename with path}
          Function  GetDate:LongInt;    {Get file date}
          Function  GetSize:LongInt;    {Get file size}
       End;

    Type
       TFileArray32=Array[1..$fff0] of Char;

    Type
       TFileRec32=Record
          MsgBuffer:^TFileArray32;
          BufferStart:LongInt;
          BufferFile:File;
          CurrentStr:String;
          StringFound:Boolean;
          BufferPtr,
          Error:Word;
          BufferChars,
          BufferSize:Integer;
       End;

    Type
       TFile32=Object
          TF:^TFileRec32;
          Procedure Init;
          Procedure Done;
          Function  GetString:String;           {Get string from file}
          Function  GetUString:String;          {Get LF delimited string}
          Function  GetCString:String;          {Get #0 delimited string}
          Procedure GetBlock(Var Buf;NumToRead:Integer);
          Function  OpenTextFile(FilePath:String):Boolean;  {Open file}
          Function  CloseTextFile:Boolean;      {Close file}
          Function  GetChar:Char;               {Internal use}
          Procedure BufferRead;                 {Internal use}
          Function  StringFound:Boolean;        {Was a string found}
          Function  SeekTextFile(SeekPos:LongInt):Boolean; {Seek to position}
          Function  GetTextPos:LongInt;         {Get text file position}
          Function  Restart:Boolean;            {Reset to start of file}
          Procedure SetBufferSize(BSize:Word);  {Set buffer size}
       End;

    Var
       MKFileError: Word;

    procedure Delay(msecs:integer);
    Function  GetEnv(Str:String):String;
    Function  FExpand(Str:String):String;
    Procedure FSplit(Path:String; Var Dir,Name,Ext:String);
    Function  FSearch(Path: String; DirList: String): String;
    Function  FileExist(FName: String): Boolean;
    Function  SizeFile(FName: String): LongInt;
    Function  DateFile(FName: String): LongInt;
    Function  FindPath(FileName: String): String;
    Function  LongLo(InNum: LongInt): Word;
    Function  LongHi(InNum: LongInt): Word;
    Function  shAssign(Var F: File; FName: String): Boolean;
    Function  shLock(Var F; LockStart,LockLength: LongInt): Word;
    Function  shUNLock(Var F; LockStart,LockLength: LongInt): Word;
    Procedure FlushFile(Var F);
    Function  shReset(Var F: File; RecSize: Word): Boolean;
    Function  shReWrite(Var F: File; RecSize: Word): Boolean;
    Function  shRead(Var F:File; Var Rec; ReadSize: Integer; Var NumRead: Integer): Boolean;
    Function  shWrite(Var F: File; Var Rec; ReadSize: Integer): Boolean;
    Function  shOpenFile(Var F: File; PathName: String): Boolean;
    Function  shMakeFile(Var F: File; PathName: String): Boolean;
    Procedure shCloseFile(Var F: File);
    Procedure shEraseFile(Var F: File);
    Function  shSeekFile(Var F: File; FPos: LongInt): Boolean;
    Function  shFindFile(Pathname: String; Var Name: String; Var Size, Time: LongInt): Boolean;
    Procedure shSetFTime(Var F: File; Time: LongInt);
    Function  GetCurrentPath: String;
    Procedure CleanDir(FileDir: String);
    Function  IsDevice(FilePath: String): Boolean;
    Function  LoadFilePos(FN: String; Var Rec; FS: Word; FPos: LongInt): Word;
    Function  LoadFile(FN: String; Var Rec; FS: Word): Word;
    Function  SaveFilePos(FN: String; Var Rec; FS: Word; FPos: LongInt): Word;
    Function  SaveFile(FN: String; Var Rec; FS: Word): Word;
    Function  ExtendFile(FN: String; ToSize: LongInt): Word;
    Function  CreateTempDir(FN: String): String;
    Function  GetTempName(FN: String): String;
    Function  GetTextPos(Var F: Text): LongInt;
    Function  FindOnPath(FN: String; Var OutName: String): Boolean;
    Function  CopyFile(FN1: String; FN2: String): Boolean;
    Function  EraseFile(FN: String): Boolean;
    Function  MakePath(FP: String): Boolean;
    Function  DirExist(FName:String):Boolean;

    Implementation

    Uses MkString32;

    Var
       DosError:Integer;

    Function GetEnv(Str:string):String;
    Var
       LpBuffer:PChar;
       Rtn:Integer;

    Begin
       LpBuffer:=StrAlloc(1024);
       StrPCopy(LpBuffer,Str);
       Rtn:=GetEnvironmentVariable(LpBuffer,LpBuffer,1024);
       If Rtn>0 then Result:=StrPas(LpBuffer)
       Else Result:='';
       StrDispose(LpBuffer);
    End;

    Function FExpand(Str:String):String;
    Begin
       FExpand:=ExpandFileName(Str);
    End;

    Procedure FSplit(Path: String; Var Dir,Name,Ext:String);
    Begin
       Dir:=WithBackSlash(ExtractFileDir(Path));
       Name:=ExtractFileName(Path);
       Ext:=ExtractFilePath(Path);
    End;

    Function  FSearch(Path: String; DirList: String): String;
    Begin
       FSearch:=FileSearch(Path,DirList);
    End;

    Procedure FindObj.Init;
    Begin
       New(FI);
       FI^.DError := 1;
    End;

    Procedure FindObj.Done;
    Begin
       Dispose(FI);
    End;

    Procedure FindObj.FFirst(FN: String);
    Begin
       FN := FExpand(FN);
       FSplit(FN, FI^.Dir, FI^.Name, FI^.Ext);
       FI^.DError:=FindFirst(FN, faArchive + faReadOnly, FI^.SRec);
    End;

    Function  FindObj.GetName: String;
    Begin
       If Found Then GetName:=FI^.SRec.Name
       Else GetName := '';
    End;

    Function FindObj.GetFullPath: String;
    Begin
       GetFullPath:=FI^.Dir+GetName;
    End;

    Function  FindObj.GetSize: LongInt;
    Begin
      If Found Then GetSize:=FI^.SRec.Size
      Else GetSize:=0;
    End;

    Function  FindObj.GetDate: LongInt;
    Begin
       If Found Then GetDate := FI^.SRec.Time
       Else GetDate := 0;
    End;

    Procedure FindObj.FNext;
    Begin
       FI^.DError:=FindNext(FI^.SRec);
    End;

    Procedure FindObj.FDone;
    Begin
       FindClose(FI^.SRec);
    End;

    Function FindObj.Found: Boolean;
    Begin
       Found:=(FI^.DError=0);
    End;

    Function shAssign(Var F: File; FName: String): Boolean;
    Begin
       AssignFile(F,FName);
       MKFileError:=0; {duh!}
       shAssign:=True;
    End;

    Function shRead(Var F: File; Var Rec; ReadSize: Integer; Var NumRead: Integer): Boolean;
    Var
        Count: Word;
        Code: Word;

    Begin
       If IOResult<>0 then ;
       Count:=Tries;
       Code:=5;
       While ((Count>0) and (Code = 5)) Do Begin
          {$I-} BlockRead(F,Rec,ReadSize,NumRead); {$I+}
          Code:=IoResult;
          Dec(Count);
       End;
       MKFileError:=Code;
       ShRead:=(Code=0);
    End;

    Function shWrite(Var F: File; Var Rec; ReadSize: Integer): Boolean;
    Var
       Count: Word;
       Code: Word;

    Begin
       IF IOResult<>0 then ;
       Count := Tries;
       Code := 5;
       While ((Count > 0) and (Code = 5)) Do Begin
          {$I-} BlockWrite(F,Rec,ReadSize); {$I+}
          Code := IoResult;
          Dec(Count);
       End;
       MKFileError := Code;
       shWrite := (Code = 0);
    End;

    Procedure CleanDir(FileDir:String);
    Var
       SR:TSearchRec;

    Begin
       AddBackSlash(FileDir);
       DosError:=FindFirst(FileDir+'*.*',faReadOnly+faArchive,SR);
       While DosError=0 Do Begin
          DeleteFile(StrPCopy('',FileDir+SR.Name));
          DosError:=FindNext(SR);
       End;
       FindClose(SR);
    End;

    Function GetCurrentPath: String;
    Begin
       GetCurrentPath:=WithBackSlash(GetCurrentDir);
    End;

    procedure Delay(msecs:integer);
    var
       FirstTickCount:longint;
    begin
       FirstTickCount:=GetTickCount;
       repeat
          Application.ProcessMessages; {allowing access to other
                                        controls, etc.}
       until ((GetTickCount-FirstTickCount) >= Longint(msecs));
    end;

    Function shLock(Var F; LockStart,LockLength: LongInt): Word;
    Var
      Count: Word;
      Code: Word;
      TmpLong:Longint;

    Begin
       Count := Tries;
       Code := $21;
       TmpLong:=TFilerec(F).Handle;
       While ((Count > 0) and (Code = $21)) Do Begin
          If Not LockFile(TmpLong,LockStart,0,LockLength,0) then Begin
             Delay(TryDelay);
             Dec(Count);
          End
          Else Code:=0;
       End;
       If Code = 1 Then Code := 0;
       MKFileError:=Code;
       shLock := Code;
    End;

    Function shUNLock(Var F; LockStart,LockLength: LongInt): Word;
    Var
      Count: Word;
      Code: Word;
      TmpLong:Longint;

    Begin
       Count := Tries;
       Code := $21;
       TmpLong:=TFilerec(F).Handle;
       While ((Count > 0) and (Code = $21)) Do Begin
          If Not UNLockFile(TmpLong,LockStart,0,LockLength,0) then Begin
             Delay(TryDelay);
             Dec(Count);
          End
          Else Code:=0;
       End;
       If Code = 1 Then Code := 0;
       MKFileError:=Code;
       shUNLock := Code;
    End;

    Function shReset(Var F: File; RecSize: Word): Boolean;
    Var
       Count: Word;
       Code: Word;

    Begin
      If IOResult<>0 then ;
      Count := Tries;
      Code := 5;
       While ((Count > 0) and (Code = 5)) Do Begin
          {$I-} Reset(F,RecSize); {$I+}
          Code := IoResult;
          Dec(Count);
       End;
       MKFileError := Code;
       ShReset := (Code = 0);
    End;

    Function shReWrite(Var F: File; RecSize: Word): Boolean;
    Var
       Count: Word;
       Code: Word;

    Begin
      If IOResult<>0 then ;
      Count := Tries;
      Code := 5;
       While ((Count > 0) and (Code = 5)) Do Begin
          {$I-} ReWrite(F,RecSize); {$I+}
          Code := IoResult;
          Dec(Count);
       End;
       MKFileError := Code;
       ShReWrite := (Code = 0);
    End;

    Procedure FlushFile(Var F); {Dupe file handle, close dupe handle}
    Begin
       Flush(TextFile(F));
       MKFileError:=0;
    End;

    Function LongLo(InNum: LongInt): Word;
    Begin
       LongLo := InNum and $FFFF;
    End;

    Function LongHi(InNum: LongInt): Word;
    Begin
       LongHi := InNum Shr 16;
    End;

    Function SizeFile(FName: String):LongInt;
    Var
      SR: TSearchRec;

    Begin
      DosError:=FindFirst(FName,faAnyFile,SR);
      If DosError=0 Then SizeFile := SR.Size
      Else SizeFile:=-1;
      MKFileError:=DosError;
      FindClose(SR);
    End;

    Function  DateFile(FName: String): LongInt;
    Var
        SR: TSearchRec;

    Begin
       DosError:=FindFirst(FName,faAnyFile,SR);
       If DosError=0 Then DateFile:=SR.Time
       Else DateFile:=0;
       MKFileError:=DosError;
       FindClose(SR);
    End;

    Function DirExist(FName: String): Boolean;
    Var
       SR: TSearchRec;

    Begin
       if (length(FName)>1) and (FName[length(FName)] in ['\','/']) then Copy(FName,1,Length(FName)-1);
       DirExist:=FindFirst(FName+'.',faReadOnly+faHidden+faArchive+faDirectory,SR)=0;
       FindClose(SR);
    End;

    Function FileExist(FName: String): Boolean;
    Begin
       FileExist:=FileExists(FName);
    End;

    Function FindPath(FileName: String):String;
    Begin
       FindPath := FileName;
       If FileExist(FileName) Then FindPath:=FExpand(FileName)
       Else FindPath:=FExpand(FSearch(FileName,GetEnv('PATH')));
    End;

    Procedure TFile32.BufferRead;
      Begin
      TF^.BufferStart := FilePos(TF^.BufferFile);
      if Not shRead (TF^.BufferFile,TF^.MsgBuffer^ , TF^.BufferSize, TF^.BufferChars) Then
        TF^.BufferChars := 0;
      TF^.BufferPtr := 1;
      End;

    Function TFile32.GetChar: Char;
      Begin
      If TF^.BufferPtr > TF^.BufferChars Then
        BufferRead;
      If TF^.BufferChars > 0 Then
        GetChar := TF^.MsgBuffer^[TF^.BufferPtr]
      Else
        GetChar := #0;
      Inc(TF^.BufferPtr);
      If TF^.BufferPtr > TF^.BufferChars Then
        BufferRead;
      End;

    Function TFile32.GetString: String;

      Var
        TempStr: String;
        GDone: Boolean;
        Ch: Char;

      Begin
        TempStr := '';
        GDone := False;
        TF^.StringFound := False;
        While Not GDone Do
          Begin
          Ch := GetChar;
          Case Ch Of
            #0:  If TF^.BufferChars = 0 Then
                   GDone := True
                 Else
                   Begin

                   TempStr:=TempStr+Ch;
                   TF^.StringFound := True;
                   {the following not true in 32bit}
    {               If Length(TempStr) = 255 Then GDone := True;}
                   End;
            #10:;
            #26:;
            #13: Begin
                 GDone := True;
                 TF^.StringFound := True;
                 End;
            Else
              Begin
                TempStr:=TempStr+Ch;
                TF^.StringFound := True;
                {following not valid in 32bit!}
    {            If Length(TempStr) = 255 Then GDone := True;}
              End;
            End;
          End;
        GetString := TempStr;
      End;

    Function TFile32.GetCString: String;

      Var
        TempStr: String;
        GDone: Boolean;
        Ch: Char;

      Begin
      TempStr := '';
      GDone := False;
      TF^.StringFound := False;
      While Not GDone Do
        Begin
        Ch := GetChar;
        Case Ch Of
          #0:  If TF^.BufferChars = 0 Then
                 GDone := True
               Else
                 Begin
                 TF^.StringFound := True;
                 End;
          Else
            Begin
            TempStr:=TempStr+Ch;
            TF^.StringFound := True;
            End;
          End;
        End;
      GetCString := TempStr;
      End;

    Procedure  TFile32.GetBlock(Var Buf;NumToRead:Integer);
    Var
       Loop:Integer;
       TmpStr:String;

    Begin
       TmpStr:='';
       Loop:=0;
       While Loop<NumToRead do Begin
          TmpStr:=TmpStr+GetChar;
          Inc(Loop);
       End;
       Move(TmpStr[1],Buf,NumToRead);
       TF^.StringFound:=True;
    End;

    Function TFile32.GetUString:String;
      Var
        TempStr: String;
        GDone: Boolean;
        Ch: Char;

      Begin
      TempStr := '';
      GDone := False;
      TF^.StringFound := False;
      While Not GDone Do Begin
        Ch := GetChar;
        Case Ch Of
          #0:  If TF^.BufferChars=0 Then
                 GDone:=True
               Else
                 Begin
                 TempStr:=TempStr+Ch;
                 TF^.StringFound := True;
                 {the following not valid in 32bit}
    {             If Length(TempStr) = 255 Then GDone := True;}
                 End;
          #13:;
          #26:;
          #10: Begin
               GDone := True;
               TF^.StringFound := True;
               End;
          Else
            Begin
            TempStr:=TempStr+Ch;
            TF^.StringFound := True;
            {the following not true in 32bit}
    {        If Length(TempStr) = 255 Then GDone := True;}
            End;
          End;
        End;
      GetUString := TempStr;
      End;

    Function TFile32.OpenTextFile(FilePath: String): Boolean;
      Begin
      If Not shAssign(TF^.BufferFile,FilePath) Then;
      FileMode := fmReadOnly + fmDenyNone;
      If Not shReset(TF^.BufferFile,1) Then
        OpenTextFile := False
      Else
        Begin
        BufferRead;
        If TF^.BufferChars > 0 Then
          TF^.StringFound := True
        Else
          TF^.StringFound := False;
        OpenTextFile := True;
        End;
      End;

    Function TFile32.SeekTextFile(SeekPos: LongInt): Boolean;
      Begin
      TF^.Error := 0;
      If ((SeekPos < TF^.BufferStart) Or (SeekPos > TF^.BufferStart + TF^.BufferChars)) Then
        Begin
        {$I-} Seek(TF^.BufferFile, SeekPos); {$I+}
        TF^.Error := IoResult;
        BufferRead;
        End
      Else
        Begin
        TF^.BufferPtr := SeekPos + 1 - TF^.BufferStart;
        End;
      SeekTextFile := (TF^.Error = 0);
      End;

    Function TFile32.GetTextPos: LongInt;       {Get text file position}
      Begin
      GetTextPos := TF^.BufferStart + TF^.BufferPtr - 1;
      End;

    Function TFile32.Restart: Boolean;
      Begin
      Restart := SeekTextFile(0);
      End;

    Function TFile32.CloseTextFile: Boolean;
      Begin
      {$I-} CloseFile(TF^.BufferFile); {$I+}
      CloseTextFile := (IoResult = 0);
      End;

    Procedure TFile32.SetBufferSize(BSize: Word);
      Begin
      FreeMem(TF^.MsgBuffer, TF^.BufferSize);
      TF^.BufferSize := BSize;
      GetMem(TF^.MsgBuffer, TF^.BufferSize);
      TF^.BufferChars := 0;
      TF^.BufferStart := 0;
      If SeekTextFile(GetTextPos) Then;
      End;

    Procedure TFile32.Init;
      Begin
      New(TF);
      TF^.BufferSize := 2048;
      GetMem(TF^.MsgBuffer, TF^.BufferSize);
      End;

    Procedure TFile32.Done;
      Begin
      {$I-} CloseFile(TF^.BufferFile); {$I+}
      If IoResult <> 0 Then;
      FreeMem(TF^.MsgBuffer, TF^.BufferSize);
      Dispose(TF);
      End;

    Function TFile32.StringFound: Boolean;
      Begin
      StringFound := TF^.StringFound;
      End;

    Function  shOpenFile(Var F: File; PathName: String): Boolean;
    Begin
       shAssign(F,PathName);
       FileMode:=fmReadWrite+fmDenyNone;
       shOpenFile:=shReset(f,1);
    End;

    Function  shMakeFile(Var F: File; PathName: String): Boolean;
    Begin
       shAssign(F,PathName);
       FileMode:=fmReadWrite+fmDenyNone;
       shMakeFile:=shRewrite(f,1);
    END;

    Procedure shCloseFile(Var F: File);
    Begin
       If (IOresult <> 0) Then;
       {$I-} CloseFile(F); {$I+}
       MKFileError:=IOResult;
    End;

    Procedure shEraseFile(Var F: File);
    Begin
       If (IOresult <> 0) Then;
       {$I-} Erase(F); {$I+}
       MKFileError:=IOResult;
    End;

    Function  shSeekFile(Var F: File; FPos: LongInt): Boolean;
    Begin
       If IOResult=0 then ;
       {$I-} Seek(F,FPos); {$I+}
       MKFileError:=IOResult;
       shSeekFile := (MKFileError = 0);
    End;

    Function  shFindFile(Pathname: String; Var Name: String; Var Size, Time: LongInt): Boolean;
    Var
       SR: TSearchRec;

    Begin
       DosError:=FindFirst(PathName, faArchive, SR);
       If (DosError = 0) Then Begin
          shFindFile := True;
          Name := Sr.Name;
          Size := Sr.Size;
          Time := Sr.Time;
       End
       Else Begin
          shFindFile := False;
       End;
       FindClose(SR);
    End;

    Procedure shSetFTime(Var F: File; Time: LongInt);
    Begin
       FileSetDate(TFileRec(F).Handle,Time);
    End;

    Function IsDevice(FilePath: String): Boolean;
    Begin
       IsDevice:=False; {Expand this later!}
    End;

    Function LoadFile(FN: String; Var Rec; FS: Word): Word;
    Begin
       LoadFile := LoadFilePos(FN, Rec, FS, 0);
    End;

    Function LoadFilePos(FN: String; Var Rec; FS: Word; FPos: LongInt): Word;
    Var
       F: File;
       Error: Word;
       NumRead:Integer;

    Begin
      Error := 0;
      If Not FileExist(FN) Then Error := 8888;
      If Error = 0 Then Begin
        If Not shAssign(F, FN) Then Error := MKFileError;
      End;
      FileMode := fmReadOnly + fmDenyNone;
      If Not shReset(F,1) Then Error := MKFileError;
      If Error = 0 Then Begin
        {$I-} Seek(F, FPos); {$I+}
        Error := IoResult;
      End;
      If Error = 0 Then
        If Not shRead(F, Rec, FS, NumRead) Then
          Error := MKFileError;
      If Error = 0 Then
        Begin
        {$I-} CloseFile(F); {$I+}
        Error := IoResult;
        End;
      LoadFilePos := Error;
      End;

    Function SaveFile(FN: String; Var Rec; FS: Word): Word;
       Begin
       SaveFile := SaveFilePos(FN, Rec, FS, 0);
       End;

    Function SaveFilePos(FN: String; Var Rec; FS: Word; FPos: LongInt): Word;
      Var
        F: File;
        Error: Word;

      Begin
      Error := 0;
      If Not shAssign(F, FN) Then
        Error := MKFileError;
      FileMode := fmReadWrite + fmDenyNone;
      If FileExist(FN) Then
        Begin
        If Not shReset(F,1) Then
          Error := MKFileError;
        End
      Else
        Begin
        {$I-} ReWrite(F,1); {$I+}
        Error := IoResult;
        End;
      If Error = 0 Then
        Begin
        {$I-} Seek(F, FPos); {$I+}
        Error := IoResult;
        End;
      If Error = 0 Then
        If FS > 0 Then
          Begin
          If Not shWrite(F, Rec, FS) Then
            Error := MKFileError;
          End;
      If Error = 0 Then
        Begin
        {$I-} CloseFile(F); {$I+}
        Error := IoResult;
        End;
      SaveFilePos := Error;
      End;

    Function ExtendFile(FN: String; ToSize: LongInt): Word;
    {Pads file with nulls to specified size}
      Type
        FillType = Array[1..8000] of Byte;

      Var
        F: File;
        Error: Word;
        FillRec: ^FillType;

      Begin
      Error := 0;
      New(FillRec);
      If FillRec = Nil Then
        Error := 10;
      If Error = 0 Then
        Begin
        FillChar(FillRec^, SizeOf(FillRec^), 0);
        If Not shAssign(F, FN) Then
        Error := MKFileError;
        FileMode := fmReadWrite + fmDenyNone;
        If FileExist(FN) Then
          Begin
          If Not shReset(F,1) Then
            Error := MKFileError;
          End
        Else
          Begin
          {$I-} ReWrite(F,1); {$I+}
          Error := IoResult;
          End;
        End;
      If Error = 0 Then
        Begin
        {$I-} Seek(F, FileSize(F)); {$I+}
        Error := IoResult;
        End;
      If Error = 0 Then
        Begin
        While ((FileSize(F) < (ToSize - SizeOf(FillRec^))) and (Error = 0)) Do
          Begin
          If Not shWrite(F, FillRec^, SizeOf(FillRec^)) Then
            Error := MKFileError;
          End;
        End;
      If ((Error = 0) and (FileSize(F) < ToSize)) Then
        Begin
        If Not shWrite(F, FillRec^, ToSize - FileSize(F)) Then
          Error := MKFileError;
        End;
      If Error = 0 Then
        Begin
        {$I-} CloseFile(F); {$I+}
        Error := IoResult;
        End;
      Dispose(FillRec);
      ExtendFile := Error;
      End;

    Function  CreateTempDir(FN: String): String;
    Var
       S:String;

    Begin
       S:=WithBackSlash(GetTempName(FN));
       ForceDirectories(S);
       CreateTempDir:=S;
    End;

    Function  GetTempName(FN: String): String;
    Var
       S:String;
    Begin
       S:=FN+'TEMP'+IntToStr(Random(1234))+'.$$$';
       While FileExists(S) do S:=FN+'TEMP'+IntToStr(Random(1234))+'.$$$';
       GetTempName:=S;
    End;

    Function  GetTextPos(Var F: Text): LongInt;
    Begin
       {todo}
    End;
    (*  Type WordRec = Record
        LongLo: Word;
        LongHi: Word;
        End;

      Var
       {$IFDEF WINDOWS}
       TR: TTextRec Absolute F;
       {$ELSE}
       TR: TextRec Absolute F;
       {$ENDIF}
       Tmp: LongInt;
       Handle: Word;
       {$IFNDEF BASMINT}
         {$IFDEF WINDOWS}
         Regs: TRegisters;
         {$ELSE}
         Regs: Registers;
         {$ENDIF}
       {$ENDIF}

      Begin
      Handle := TR.Handle;
      {$IFDEF BASMINT}
      Asm
        Mov ah, $42;
        Mov al, $01;
        Mov bx, Handle;
        Mov cx, 0;
        Mov dx, 0;
        Int $21;
        Jnc @TP2;
        Mov ax, $ffff;
        Mov dx, $ffff;
        @TP2:
        Mov WordRec(Tmp).LongLo, ax;
        Mov WordRec(Tmp).LongHi, dx;
        End;
      {$ELSE}
      Regs.ah := $42;
      Regs.al := $01;
      Regs.bx := Handle;
      Regs.cx := 0;
      Regs.dx := 0;
      MsDos(Regs);
      If (Regs.Flags and 1) <> 0 Then
        Begin
        Regs.ax := $ffff;
        Regs.dx := $ffff;
        End;
      WordRec(Tmp).LongLo := Regs.Ax;
      WordRec(Tmp).LongHi := Regs.Dx;
      {$ENDIF}
      If Tmp >= 0 Then
        Inc(Tmp, TR.BufPos);
      GetTextPos := Tmp;
      End; *)

    Function FindOnPath(FN: String; Var OutName: String): Boolean;
      Var
        TmpStr: String;

      Begin
      If FileExist(FN) Then
        Begin
        OutName := FExpand(FN);
        FindOnPath := True;
        End
      Else
        Begin
        TmpStr := FSearch(FN, GetEnv('Path'));
        If FileExist(TmpStr) Then
          Begin
          OutName := TmpStr;
          FindOnPath := True;
          End
        Else
          Begin
          OutName := FN;
          FindOnPath := False;
          End;
        End;
      End;

    Function  CopyFile(FN1: String; FN2: String): Boolean;
      Type
        TmpBufType = Array[1..8192] of Byte;

      Var
        F1: File;
        F2: File;
        NumRead:Integer;
        Buf: ^TmpBufType;
        Error: Word;

      Begin
      New(Buf);
      AssignFile(F1, FN1);
      FileMode := fmReadOnly + fmDenyNone;
      {$I-} Reset(F1, 1); {$I+}
      Error := IoResult;
      If Error = 0 Then
        Begin
        AssignFile(F2, FN2);
        FileMode := fmReadWrite + fmDenyNone;
        {$I-} ReWrite(F2, 1); {$I+}
        Error := IoResult;
        End;
      If Error = 0 Then
        Begin
        {$I-} BlockRead(F1, Buf^, SizeOf(Buf^), NumRead); {$I+}
        Error := IoResult;
        While ((NumRead <> 0) and (Error = 0)) Do
          Begin
          {$I-} BlockWrite(F2, Buf^, NumRead); {$I+}
          Error := IoResult;
          If Error = 0 Then
            Begin
            {$I-} BlockRead(F1, Buf^, SizeOf(Buf^), NumRead); {$I+}
            Error := IoResult;
            End;
          End;
        End;
      If Error = 0 Then
        Begin
        {$I-} CloseFile(F1); {$I+}
        Error := IoResult;
        End;
      If Error = 0 Then
        Begin
        {$I-} CloseFile(F2); {$I+}
        Error := IoResult;
        End;
      Dispose(Buf);
      CopyFile := (Error = 0);
      End;

    Function  EraseFile(FN: String): Boolean;
    Begin
       EraseFile:=DeleteFile(FN);
    End;

    Function  MakePath(FP: String): Boolean;
    Begin
       AddBackSlash(FP);
       ForceDirectories(FP);
       MakePath := DirExist(FP);
    End;

    End.

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]