Unit MKFile;

{$I-}
{$IFDEF MSDOS}
{$V-,S-,F+,R-,O+}
{$ENDIF}

Interface

Uses
  tMisc,
{$IFDEF OS2}
  Os2Base,
{$ENDIF}
{$IFNDEF WIN32}
  DOS,
{$ELSE}
  SysUtils,
  Windows,
{$ENDIF}
  OpCrt,
  Objects;

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

Type
  tMkStream = Record
    S         : {$IFNDEF WIN32} PBufstream {$ELSE} File {$ENDIF};
    FileName  : PathStr;
    RecSize   : LongInt;
  End;

  shFile = tMkStream;

Function DateFile (FName: String): LongInt;
Function FindPath (FileName: String): String;
Function LongLo (InNum: LongInt): Word;
Function LongHi (InNum: LongInt): Word;
Function UnLockFile (Var F: shFile; LockStart: LongInt; LockLength: LongInt): Word;
Function shAssign (Var F: shFile; FName: String): Boolean;
Function shLock (Var F: shFile; LockStart, LockLength: LongInt): Word;
Procedure shFlush (Var F: shFile); {Dupe file handle, close dupe handle}
Function shReset (Var F: shFile; RecSize: Word): Boolean;
Function shReWrite (Var F: shFile; RecSize: Word): Boolean;
Function shRead (Var F: shFile; Var Rec; ReadSize: Word; Var NumRead: SysInt): Boolean;
Function shWrite (Var F: shFile; Var Rec; ReadSize: Word): Boolean;
Function shSeekFile (Var F: shFile; FPos: LongInt): 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 GetTempName (FN: String): String;
Function FindOnPath (FN: String; Var OutName: String): Boolean;
Function MakePath (FP: String): Boolean;
Function shClose (Var F: shFile): Boolean;
Function shFileSize (Var F: shFile): LongInt;
Function shFilePos (Var F: shFile): LongInt;
Function shEoF (Var F: shFile): Boolean;
Function shIOResult: Byte;
Procedure shTruncate (Var F: shFile);

Implementation

Const
  Tries     = 150;
  TryDelay  = 100;
  BufSize   = 2000;

Var
  IORez : Byte;

Function shAssign (Var F: shFile; FName: String): Boolean;
Begin
  F. FileName := FName;
{$IFNDEF WIN32}
  F. S := Nil;
{$ELSE}
  AssignFile (F. S, FName);
{$ENDIF}
End;

Function shRead (Var F: shFile; Var Rec; ReadSize: Word; Var NumRead: SysInt): Boolean;
{$IFNDEF WIN32}
Var
  Count, Code : SysInt;
  Tmp         : LongInt;
{$ENDIF}

Begin

{$IFNDEF WIN32}

  If (F. S^. GetSize-F. S^. GetPos)-ReadSize * F. RecSize < 0 Then
  Begin
    Tmp := F. S^. GetSize-F. S^. GetPos;
    If Tmp < 0 Then Tmp := 0;
    NumRead := Trunc (Tmp/F. RecSize);
  End Else
    NumRead := ReadSize;

  Count := Tries; Code := 5;

  While ((Count > 0) And (Code = 5)) Do
  Begin
    F. S^. Read (Rec, NumRead * F. RecSize);
    Code := F. S^. ErrorInfo;
    If Code = 0 Then Break;
    Dec (Count);
  End;

  If (Code = 0) and (NumRead <> ReadSize) Then {Code := 100} Else
  If Code <> 0 Then NumRead := 0 Else NumRead := ReadSize;
  IORez := Code;
  ShRead := (Code = 0);

{$ELSE}

  BlockRead (F. S, Rec, ReadSize, NumRead);
  IORez := IOResult;
  shRead := IORez = 0;

{$ENDIF}

End;

Function shWrite (Var F: shFile; Var Rec; ReadSize: Word): Boolean;
{$IFNDEF WIN32}
Var
  Count, Code      : Word;
{$ENDIF}

Begin
{$IFNDEF WIN32}

  Count := Tries;
  Code := 5;

  While ((Count > 0) And (Code = 5)) Do
  Begin
    F. S^. Write (Rec, ReadSize * F. RecSize);
    Code := F. S^. ErrorInfo;
    Dec (Count);
  End;

  IORez := Code;
  shWrite := (Code = 0);

{$ELSE}

  BlockWrite (F. S, Rec, ReadSize);
  IORez := IOResult;
  shWrite := IORez = 0;

{$ENDIF}

End;

Function shLock (Var F: shFile; LockStart, LockLength: LongInt): Word;
Begin
  shLock := 0;
End;

Function shReSet (Var F: shFile; RecSize: Word): Boolean;
{$IFNDEF WIN32}
Var
  Count, Code, Mode   : Word;
{$ENDIF}

Begin
{$IFNDEF WIN32}

  Count := Tries;
  Code := 5;
  F. RecSize := RecSize;
  If F. S <> nil Then
  Begin
    Dispose (F. S, Done);
    F. S := Nil;
  End;

  While ((Count > 0) And (Code = 5)) Do
  Begin
    If FileMode = fmReadOnly Then Mode := stOpenRead Else
    If FileMode = fmWriteOnly Then Mode := stOpenWrite
    Else Mode := stOpen;

    F. S := New (PBufStream, Init (F. FileName, Mode, BufSize));
    Code := F. S^. ErrorInfo;

    If Code in [110, 2] Then
    Begin
      F. S := New (PBufStream, Init (F. FileName, stCreate, BufSize));
      Code := F. S^. ErrorInfo;
    End;

    If Code <> 0 Then
    Begin
      Dispose (F. S, Done);
      F. S := nil;
    End;

    Dec (Count);
  End;

  IORez := Code;
  ShReset := (Code = 0);

{$ELSE}

  F. RecSize := RecSize;
  IORez := IOResult;
  ReSet (F. S, F. RecSize);
  If IOResult <> 0 Then
  Begin
    IORez := IOResult;
    ReWrite (F. S, F. RecSize);
  End;
  IORez := IOResult;
  ShReSet := IORez = 0;

{$ENDIF}
End;

Function shReWrite (Var F: shFile; RecSize: Word): Boolean;
{$IFNDEF WIN32}
Var
  Count, Code   : Word;
{$ENDIF}

Begin
{$IFNDEF WIN32}

  Count := Tries;
  Code := 5;
  F. RecSize := RecSize;
  If F. S <> nil Then
  Begin
    Dispose (F. S, Done);
    F. S := Nil;
  End;

  While ((Count > 0) And (Code = 5)) Do
  Begin
    F. S := New (PBufStream, Init (F. FileName, stCreate, BufSize));
    F. RecSize := RecSize;
    Code := F. S^. ErrorInfo;
    Dec (Count);
  End;

  IORez := Code;
  shReWrite := (Code = 0);

{$ELSE}

  F. RecSize := RecSize;
  ReWrite (F. S, RecSize);
  IORez := IOResult;
  shReWrite := IORez = 0;

{$ENDIF}
End;

Procedure shFlush (Var F: shFile); {Dupe file handle, close dupe handle}
Begin
{$IFNDEF WIN32}
  F. S^. Flush;
{$ELSE}
  {Flush (F. S);}
{$ENDIF}
End;

Function LockFile (Var F; LockStart: LongInt; LockLength: LongInt): Word;
{$IFDEF MSDOS}
Var
  Handle: Word Absolute F;
  Tmp: Word;
  StrtHi: Word;
  StrtLo: Word;
  LgHi: Word;
  LgLo: Word;
  Regs: Registers;
{$ENDIF}

Begin
{$IFDEF MSDOS}
  Tmp := Handle;
  StrtHi := LongHi (LockStart);
  StrtLo := LongLo (LockStart);
  LgHi := LongHi (LockLength);
  LgLo := LongLo (LockLength);
  Regs. AH := $5c;
  Regs. AL := $00;
  Regs. BX := Tmp;
  Regs. CX := StrtHi;
  Regs. DX := StrtLo;
  Regs. SI := LgHi;
  Regs. DI := LgLo;
  MsDos (Regs);
  If (Regs. Flags And 1) = 0 Then
  Begin
    Regs. AX := 0;
  End;
  Tmp := Regs. AX;
  If Tmp = 1 Then
    Tmp := 0;
  LockFile := Tmp;
{$ELSE}
  LockFile := 0;
{$ENDIF}
End;

Function UnLockFile (Var F: shFile; LockStart: LongInt; LockLength: LongInt): Word;
Begin
  UnLockFile := 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  DateFile (FName: String): LongInt;
Var
  SR: {$IFNDEF WIN32} SearchRec {$ELSE} TSearchRec {$ENDIF};

Begin
{$IFDEF WIN32}
  DOSerror :=
{$ENDIF}
  FindFirst (FName, AnyFile, SR);
  If DosError = 0 Then
    DateFile := SR. Time
  Else
    DateFile := 0;
End;

Function FindPath (FileName: String): String;
Begin
  FindPath := FileName;
  If FileExists (FileName) Then
    FindPath := {$IFNDEF WIN32} FExpand {$ELSE} ExpandFileName {$ENDIF} (FileName)
  Else
    FindPath :={$IFNDEF WIN32} FExpand {$ELSE} ExpandFileName {$ENDIF}
               ({$IFNDEF WIN32} FSearch {$ELSE} FileSearch {$ENDIF}
               (FileName, GetEnv ('PATH')));
End;

Procedure shCloseFile (Var F: shFile);
Begin
{$IFNDEF WIN32}
  Dispose (F. S, Done);
  F. S := Nil;
{$ELSE}
  Close (F. S);
{$ENDIF}
End;

Function shSeekFile (Var F: shFile; FPos: LongInt): Boolean;
{$IFNDEF WIN32}
Var
  i, k  : Word;
  C     : Char;
{$ENDIF}

Begin
{$IFNDEF WIN32}
  If (F. S^. Status = stCreate) and (FPos * F. RecSize > F. S^. GetSize) Then
  Begin
    C := #0;
    k := (FPos-F. S^. GetSize) * F. RecSize;
    For i := 1 To k Do F. S^. Write (C, 1);
  End;

  F. S^. Seek (FPos * F. RecSize);
  shSeekFile := (F. S^. ErrorInfo = 0);
{$ELSE}
  Seek (F. S, FPos);
  IORez := IOResult;
  shSeekFile := IORez = 0;
{$ENDIF}
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        : shFile;
  Error    : Word;
  NumRead  : SysInt;

Begin
  Error := 0;
  If Not FileExists (FN) Then Error := 8888;

  If Error = 0 Then
  If Not shAssign (F, FN) Then Error := IORez;

  FileMode := fmReadOnly + fmDenyNone;

  If Not shReset (F, 1) Then Error := IORez;

  If Error = 0 Then
  Begin
    shSeekFile (F, FPos);
    Error := IOResult;
  End;

  If Error = 0 Then
  If Not shRead (F, Rec, FS, NumRead) Then Error := IORez;

  If Error = 0 Then
  Begin
    shClose (F);
    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     : shFile;
  Error : Word;

Begin
  Error := 0;
  If Not shAssign (F, FN) Then Error := IORez;
  FileMode := fmReadWrite + fmDenyNone;

  If FileExists (FN) Then
  Begin
    If Not shReset (F, 1) Then Error := IORez;
  End Else
  Begin
    shReWrite (F, 1);
    Error := IORez;
  End;

  If Error = 0 Then
  Begin
    shSeekFile (F, FPos);
    Error := IORez;
  End;

  If Error = 0 Then If FS > 0 Then
  If Not shWrite (F, Rec, FS) Then Error := IORez;

  If Error = 0 Then
  Begin
    shClose (F);
    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         : shFile;
  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 := IORez;
    FileMode := fmReadWrite + fmDenyNone;
    If FileExists (FN) Then
    Begin
      If Not shReset (F, 1) Then
        Error := IORez;
    End Else
    Begin
      shReWrite (F, 1);
      Error := IOResult;
    End;
  End;

  If Error = 0 Then
  Begin
    shSeekFile (F, {$IFNDEF WIN32} F. S^. GetSize {$ELSE} FileSize (F. S) {$ENDIF});
    Error := IOResult;
  End;

  If Error = 0 Then
  Begin
    While (({$IFNDEF WIN32} F. S^. GetSize {$ELSE} FileSize (F. S)
            {$ENDIF} < (ToSize - SizeOf (FillRec^))) And (Error = 0)) Do
    Begin
      If Not shWrite (F, FillRec^, SizeOf (FillRec^)) Then
        Error := IORez;
    End;
  End;

  If ((Error = 0) And ({$IFNDEF WIN32} F. S^. GetSize {$ELSE} FileSize (F. S) {$ENDIF} < ToSize)) Then
  If Not shWrite (F, FillRec^, ToSize - {$IFNDEF WIN32} F. S^. GetSize {$ELSE} FileSize (F. S) {$ENDIF}) Then Error := IORez;

  If Error = 0 Then
  Begin
    shClose (F);
    Error := IOResult;
  End;

  Dispose (FillRec);
  ExtendFile := Error;
End;

Function GetTempName (FN: String): String;
Var
  FH     : Word;
  TmpStr : String;

Begin
  TmpStr := AddBackSlash (FN);

  Randomize;
  FH := Random (65534);

  While FileExists (TmpStr + HexL (FH)) Do
  Begin
    FH := Random (65534);
  End;

  TmpStr := TmpStr + HexL (FH);
  GetTempName := TmpStr;

End;

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

Begin
  If FileExists (FN) Then
  Begin
    OutName := {$IFNDEF WIN32} FExpand {$ELSE} ExpandFileName {$ENDIF} (FN);
    FindOnPath := True;
  End
  Else
  Begin
    TmpStr := {$IFNDEF WIN32} FSearch {$ELSE} FileSearch {$ENDIF} (FN, GetEnv ('Path'));
    If FileExists (TmpStr) Then
    Begin
      OutName := TmpStr;
      FindOnPath := True;
    End
    Else
    Begin
      OutName := FN;
      FindOnPath := False;
    End;
  End;
End;

Function MakePath (FP: String): Boolean;
Var
  i : Word;

Begin
  FP := AddBackSlash (FP);

  If Not DirExists (FP) Then
  Begin
    i := 2;
    While (i <= Length (FP)) Do
    Begin
      If FP [i] = '\' Then
      Begin
        If FP [i - 1] <> ':' Then
        Begin
          MkDir (Copy (FP, 1, i - 1));
          If IOResult <> 0 Then;
        End;
      End;
      Inc (i);
    End;
  End;

  MakePath := DirExists (FP);
End;

Var
  i     : LongInt;

Function shFileSize (Var F: shFile): LongInt;
Begin
  i := {$IFNDEF WIN32} F. S^. GetSize {$ELSE} FileSize (F. S) {$ENDIF};
{$IFNDEF WIN32}
  i := Trunc (i/F. RecSize);
{$ENDIF}
  shFileSize := i;
End;

Function shFilePos (Var F: shFile): LongInt;
Begin
  i := {$IFNDEF WIN32} F. S^. GetPos {$ELSE} FilePos (F. S) {$ENDIF};
{$IFNDEF WIN32}
  i := Trunc (i/F. RecSize);
{$ENDIF}
  shFilePos := i;
End;

Function shEoF (Var F: shFile): Boolean;
Begin
  shEoF := shFileSize (F) <= shFilePos (F);
End;

Function shClose (Var F: shFile): Boolean;
Begin
{$IFNDEF WIN32}
  If F. S <> nil Then
  Begin
    F. S^. Flush;
    Dispose (F. S, Done);
    F. S := nil;
  End;
{$ELSE}
  Close (F. S);
{$ENDIF}

  shClose := True;
End;

Function shIOResult: Byte;
Begin
  shIOResult := IORez;
  IORez := 0;
End;

Procedure shTruncate (Var F: shFile);
Begin
{$IFNDEF WIN32}
  F. S^. Truncate;
{$ELSE}
  Truncate (F. S);
{$ENDIF}

End;

End.