{:::::::::::::::::::::::::::::::::::::::::
::      Sito:  www.byteman.it  OpenWeb  ::
::  Raccolta:  Particelle PAS+ASM       ::
::    Autore:  Salvo Rosta aka byteman  ::
::    Titolo:  TPUFILE.IMP              ::
:: Revisione:  22-08-1995               ::
:::::::::::::::::::::::::::::::::::::::::}


{$L \SORG\SORGTPU\TPUFILE\XGetDrv.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XOpenF.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XSizeF.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XSeekF.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XRdWrF.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XCloseF.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XKillF.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XDiskVF.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XDiskRW.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XDiskRS.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XDiskVFC.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XDiskRWC.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XDiskRSC.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XDiskSec.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XVerify.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XScrollF.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XScanF.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XDirF.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XRedOut.OBJ}
{$L \SORG\SORGTPU\TPUFILE\XExist.OBJ}




Procedure DiskFree(DV: Byte; Var SC,AV,BS,TT: Word);
Begin
  ASM
    MOV   DL,DV
    MOV   AH,36h
    INT   21h
    LES   DI,[BP+4]
    MOV   ES:[DI],DX
    LES   DI,[BP+8]
    MOV   ES:[DI],CX
    LES   DI,[BP+12]
    MOV   ES:[DI],BX
    LES   DI,[BP+16]
    MOV   ES:[DI],AX
  END;
End;

Function  XGetDrive;             external;
Function  XCreatF;               external;
Function  XOpenF;                external;
Function  XSizeF;                external;
Procedure XSeekF;                external;
Procedure XReadF;                external;
Procedure XWriteF;               external;
Procedure XCloseF;               external;
Function  XKillF;                external;
Function  XScrollF;              external;
Function  XScanF;                external;
Function  XDirF;                 external;
Function  XRedirOut;             external;
Function  XNormOut;              external;
Function  XReadSector;           external;
Function  XWriteSector;          external;
Procedure XSetVerify;            external;
Function  XGetVerify;            external;
Function  XExist;                external;


Function  XDiskVerify;           external;
Procedure XDiskRead;             external;
Procedure XDiskWrite;            external;
Function  XDiskReset;            external;
Function  XDiskVerifyCrp;        external;
Procedure XDiskReadCrp;          external;
Procedure XDiskWriteCrp;         external;
Function  XDiskResetCrp;         external;


Function  XDiskAvail(D: Char): LongInt;
Var
  SectClust,AvailClust,ByteSect,TotalClust: Word;
  Avail: LongInt;
Begin
  DiskFree(Byte(D)-$40,SectClust,AvailClust,ByteSect,TotalClust);
  Avail:= AvailClust;
  Avail:=Avail*SectClust*ByteSect;
  XDiskAvail:=Avail;
End;

Function  XDiskTotal(D: Char): LongInt;
Var
  SectClust,AvailClust,ByteSect,TotalClust: Word;
  Total: LongInt;
Begin
  DiskFree(Byte(D)-$40,SectClust,AvailClust,ByteSect,TotalClust);
  Total:= TotalClust;
  Total:=Total*SectClust*ByteSect;
  XDiskTotal:=Total;
End;

Procedure XCompressText;
Var
    F1,F2: Text;
  FF1,FF2: File;
       St: String;
Begin
  Assign(F1,St1); Reset(F1);
  Assign(F2,St2); Rewrite(F2);
  While not Eof(F1) do begin ReadLn(F1,St); WriteLn(F2,XCompress(St)); End;
  Close(F1); Close(F2);
  Assign(FF1,St1); Reset(FF1,1);
  Assign(FF2,St2); Reset(FF2,1);
  Perc:=100-FileSize(FF2)*100/FileSize(FF1);
  Close(FF1);Close(FF2);
End;

Procedure XDeCompressText;
Var
     F2: Text;
  F3,F1: File;
     Buff,BuffP,St: String;
               K,L: Integer;
                 P: Byte;
Begin
  Assign(F1,St1); Reset(F1,1);
  Assign(F2,St2); Rewrite(F2);
  BuffP:='';
  Repeat
    K:=255-Length(BuffP);
    BlockRead(F1,Buff[1],K,L);
    Buff[0]:=Chr(Lo(L));
    Buff:=BuffP+Buff;
    Repeat
      P:=XPos(^M^J,Buff);
      If P=0 then BuffP:=Buff else begin
        St:=Copy(Buff,1,P-1);
        Delete(Buff,1,P+1);
        WriteLn(F2,XDeCompress(St));
      End;
    Until P=0;
  Until LNumR);
  If NumW<>NumR then XCopyF:=False else XCopyF:=True;
  GetFTime(F1,Time); SetFTime(F2,Time);
  Close(F1); Close(F2);
End;

Function  XAllPath;
Var
  OldDir,DirN: String;
        Drive: Byte;
Begin
  N:=XUpCase(N);
  If N[2] <> ':' then Drive:=0 else Drive:=Byte(N[1])-$40;
  GetDir(Drive,OldDir);
{$I-}
  ChDir(N);
{$I+}
  If IOResult=0 then begin
    GetDir(Drive,DirN);
    ChDir(OldDir);
  end else DirN:='';
  XAllPath:=DirN;
End;

Function  XCompF;
Var
         F1,F2: File;
   Buff1,Buff2: Array[1..2048] of byte;
        I,NumR: Word;
     DTA1,DTA2: SearchRec;
           Err: Byte;
Label ExitComp;
Begin
  Err:=0;
  FindFirst(N1,Archive+ReadOnly,DTA1);
  If DosError<> 0 then begin Err:=1; Goto ExitComp; End;
  FindFirst(N2,Archive+ReadOnly,DTA2);
  If DosError<> 0 then begin Err:=2;  Goto ExitComp; End;
  If DTA1.Size<>DTA2.Size then begin Err:=3;  Goto ExitComp; End;
  Assign(F1,N1); Reset(F1,1);
  Assign(F2,N2); Reset(F2,1);
  Repeat
    BlockRead(F1,Buff1,2048,NumR);
    BlockRead(F2,Buff2,2048,NumR);
    For I:=1 to NumR do If Buff1[I]<>Buff2[I] then Err:=4;
  Until (NumR=0) or (Err=4);
  Close(F1); Close(F2);
ExitComp:
  XCompF:=Err;
End;

Function  XWipeF;
Var
   F: File;
   Buff: Array[1..4096] of byte;
   NumR,NumW: Word;
   Time,Size: LongInt;
   I,NumBk,Resto: Word;
   FlagOK: Boolean;

Begin
  For I:=1 to 4096 do Buff[I]:=0;
  Assign(F,N); Reset(F,1);
  GetFTime(F,Time);
  Size:=FileSize(F);
  Close(F);
  Rewrite(F,1);
  NumBk:=Size div 4096;
  Resto:=Size mod 4096;
  FlagOK:=True;
  For I:=1 to NumBk do begin
    BlockWrite(F,Buff,4096,NumW);
    If NumW<>4096 then FlagOK:=False;
  End;
  BlockWrite(F,Buff,Resto,NumW);
  If NumW<>Resto then FlagOK:=False;
  SetFTime(F,Time);
  Close(F);
  XWipeF:=FlagOK;
End;

Procedure XCriptoF;
Var
   F1,F2: File;
   Mat: Array[1..4096] of byte;
   NumL,NumS: Word;
   I: Word;
Begin
  Assign(F1,St1); Reset(F1,1);
  Assign(F2,St2); Rewrite(F2,1);
  Repeat
    BlockRead(F1,Mat,SizeOf(Mat),NumL);
    For I:=1 to NumL do begin
      Mat[I]:=Not(Mat[I])+Shift;
      Inc(Shift);
    End;
    BlockWrite(F2,Mat,NumL,NumS);
  Until (NumL=0) or (NumS<>NumL);
  Close(F1);
  Close(F2);
End;

Procedure XDeCriptoF;
Var
   F1,F2: File;
   Mat: Array[1..4096] of byte;
   NumL,NumS: Word;
   I: Word;
Begin
  Assign(F1,St1); Reset(F1,1);
  Assign(F2,St2); Rewrite(F2,1);
  Repeat
    BlockRead(F1,Mat,SizeOf(Mat),NumL);
    For I:=1 to NumL do begin
      Mat[I]:=Not(Mat[I]-Shift);
      Inc(Shift);
    End;
    BlockWrite(F2,Mat,NumL,NumS);
  Until (NumL=0) or (NumS<>NumL);
  Close(F1);
  Close(F2);
End;

Function  XMoveF;
Var
                   DTA: SearchRec;
           Nome2,Nome1: String;
   PathNome2,PathNome1: String;
(*       BfNome2,BfNome1: String;
             Drv1,Drv2: String;  *)
                   Reg: Registers;
                     P: Integer;
                Result: Byte;

Begin
  PathNome1:=XMirror(XUpCase(N1));                       { Preparazione PathNome1 }
  P:=XCharPos('\',PathNome1);
  If P>0
    then begin
      Delete(PathNome1,1,P-1) ;
      PathNome1:=XMirror(PathNome1);
    end
    else PathNome1:='';
  If N2<>'' then begin
    PathNome2:=XUpCase(N2);                              { Preparazione PathNome2 }
    If PathNome2[Length(Pathnome2)]<>'\' then PathNome2:=PathNome2+'\';
  End else begin
    GetDir(0,PathNome2);
    Delete(PathNome2,1,2);
    PathNome2:=PathNome2+'\';
  End;

  FindFirst(N1,Archive+ReadOnly,DTA);
  Result:=DosError;
  While DosError=0 do begin
    Nome1:=PathNome1+DTA.Name+Chr(0);
    Nome2:=PathNome2+DTA.Name+Chr(0);
    Reg.AX:=$5600;
    Reg.DS:=Seg(Nome1);
    Reg.DX:=Ofs(Nome1)+1;
    Reg.ES:=Seg(Nome2);
    Reg.DI:=Ofs(Nome2)+1;
    MsDos(Reg);
    If (Reg.Flags and $1) = $1 then Result:=Reg.AL;
    FindNext(DTA);
  End;
  XMoveF:=Result;
End;

Function  XTestIfCD(Drive: Byte): Boolean;
{ determina se un drive corrisponde ad un CDROM }
Var
  x: Boolean;
Begin
  ASM
        MOV     BL,DRIVE                { il codice del drive in BL }
                                        { (0=A:, 1=B:, ecc.) }
        MOV     AX,150BH                { sottofunzione 0B }
	INT	2FH
        MOV     x,0
        CMP     AX,0                    { se AX=0 non  un CDROM }
        JZ      @Exit
        MOV     x,1
@Exit:
  END;
  XTestIfCD:=x;
End;

Function  XTxtFilePos(VAR F: Text): LongInt;
Var
   Adjust: Word;
  CurrPos: LongInt;
Begin
  IF TextRec(F).Mode <> fmInput then begin
    InOutRes := 104; {file non aperto per l'input}
    Exit;
  End;
  ASM
      MOV AH, 42h     {sposta il puntatore del file}
      MOV AL, 01h     {relativo alla posizione corrente }
      XOR CX, CX
      XOR DX, DX      {spiazzamento zero in CX:DX}
      LES DI, F
      MOV BX, ES:[DI] {la prima parola  l'handle}
      INT 21h
      JNC @ok
      MOV InOutRes, AX
      RET
  @ok:
      MOV Word(@Result), AX
      MOV Word(@Result+2), DX  {il risultato  pronto }
      LES DI, F
      {sottrae la porzione non letta
       del buffer dal risultato}
      MOV BX, TextRec(ES:[DI]).BufEnd
      SUB BX, TextRec(ES:[DI]).BufPos
      SUB Word(@Result), BX
      SBB Word(@Result+2), 0
  END;
END;

Procedure XTxtSeek(Var F: Text; SeekLoc: LongInt);
Var
  CurrPos: LongInt;
Begin
  If TextRec(F).Mode <> fmInput Then begin
    InOutRes := 104; {file non aperto per l'input}
    Exit;
  End;
  ASM
      MOV AH, 42h      {"sposta il puntatore del file"}
      MOV AL, 01h      {relativo alla posizione corrente}
      XOR CX, CX
      XOR DX, DX       {spiazzamento zero in CX:DX}
      LES DI, F
      MOV BX, ES:[DI]  {la prima parola  l'handle}
      INT 21h
      JNC @ok
      MOV InOutRes, AX
      RET
  @ok:
      MOV Word(CurrPos), AX
      MOV Word(CurrPos+2), DX {ha acquisito la posizione corrente}
  END;
    {-- SE la posizione che vogliamo  gi            --}
    {-- nel buffer di TextRec, usiamola!              --}
    {-- Altrimenti cerchiamo fino al punto desiderato --}
  Dec(CurrPos, TextRec(F).BufEnd);
  CurrPos:=SeekLoc - CurrPos;
  If (CurrPos >= 0) and (CurrPos < TextRec(F).BufEnd)
    then TextRec(F).BufPos := CurrPos
    else begin
      ASM
          MOV AH, 42h   {sposta il puntatore del file}
          MOV AL, 0h    {assoluto dall'inizio del file}
          MOV CX, Word(SeekLoc+2)
          MOV DX, Word(SeekLoc)     {posizione in CX:DX}
          LES DI, F
          MOV BX, ES:[DI]  {la prima parola  l'handle}
          INT 21h
          JNC @ok
          MOV InOutRes, AX
          RET
      @ok:
      END;
      TextRec(F).BufPos:=0;  {deve rileggere il buffer}
      TextRec(F).BufEnd:=0;
    End;
  END;

Function XTxtFileSize(Var F: Text): LongInt;
Var
  CurrPos: LongInt;
Begin
  If TextRec(F).Mode <> fmInput then begin
    InOutRes := 104; {file non aperto per l'input}
    Exit;
  End;
    {PRIMO acquisire la posizione corrente}
  ASM
      MOV AH, 42h     {sposta il puntatore del file}
      MOV AL, 01h     {relativo alla posizione corrente}
      XOR CX, CX
      XOR DX, DX      {spiazzamento zero in CX:DX}
      LES DI, F
      MOV BX, ES:[DI]  {la prima parola  l'handle}
      INT 21h
      JNC @ok
      MOV InOutRes, AX
      RET
  @ok:
      MOV Word(CurrPos), AX
      MOV Word(CurrPos+2), DX  {ha acquisito la posizione corrente}
  END;
    {SECONDO spostarsi alla fine del file}
  ASM
      MOV AH, 42h     {sposta il puntatore del file}
      MOV AL, 02h     {relativo alla fine del file}
      XOR CX, CX
      XOR DX, DX      {spiazzamento zero in CX:DX}
      LES DI, F
      MOV BX, ES:[DI]  {la prima parola  l'handle}
      INT 21h
      JNC @ok
      MOV InOutRes, AX
      RET
  @ok:
      MOV Word(@Result), AX
      MOV Word(@Result+2), DX  {il risultato  pronto}
  END;
    {TERZO tornare dove si era}
  ASM
      MOV AH, 42h   {sposta il puntatore del file}
      MOV AL, 0h    {assoluto dall'inizio del file}
      MOV CX, Word(CurrPos+2)
      MOV DX, Word(CurrPos) {posizione in CX:DX}
      LES DI, F
      MOV BX, ES:[DI]  {la prima parola  l'handle}
      INT 21h
      JNC @ok
      MOV InOutRes, AX
      RET
  @ok:
  END;
End;