fpc/rtl/go32v2/filutil.inc

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2000 by the Free Pascal development team

    File utility calls

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{******************************************************************************}
{ private functions                                                            }
{******************************************************************************}

{ some internal constants }

const
   ofRead        = $0000;    { Open for reading }
   ofWrite       = $0001;    { Open for writing }
   ofReadWrite   = $0002;    { Open for reading/writing }
   faFail        = $0000;    { Fail if file does not exist }
   faCreate      = $0010;    { Create if file does not exist }
   faOpen        = $0001;    { Open if file exists }
   faOpenReplace = $0002;    { Clear if file exists }


{  converts S to a pchar and copies it to the transfer-buffer.   }

procedure StringToTB(const S: string);
var P: pchar; Len: integer;
begin
Len := Length(S) + 1;
P := StrPCopy(StrAlloc(Len), S);
SysCopyToDos(longint(P), Len);
StrDispose(P);
end ;

{  Native OpenFile function.
   if return value <> 0 call failed.  }

function OpenFile(const FileName: string; var Handle: longint; Mode, Action: word): longint;
var
   Regs: registers;
begin
result := 0;
Handle := 0;
StringToTB(FileName);
if LFNSupport then Regs.Eax:=$716c
else Regs.Eax:=$6c00;
Regs.Edx := Action;                   { Action if file exists/not exists }
Regs.Ds := tb_segment;
Regs.Esi := tb_offset;
Regs.Ebx := $2000 + (Mode and $ff);   { file open mode }
Regs.Ecx := $20;                      { Attributes }
RealIntr($21, Regs);
if Regs.Flags and CarryFlag <> 0 then result := Regs.Ax
else Handle := Regs.Eax;
end ;

{******************************************************************************}
{ Public functions                                                             }
{******************************************************************************}


Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
var e: integer;
Begin
e := OpenFile(FileName, result, Mode, faOpen);
if e <> 0 then result := -1;
end ;


Function FileCreate (Const FileName : String) : Longint;
var e: integer;
begin
e := OpenFile(FileName, result, ofReadWrite, faCreate or faOpenReplace);
if e <> 0 then result := -1;
end;


Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
begin
result := Do_Read(Handle, longint(@Buffer), Count);
end;


Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
begin
result := Do_Write(Handle, longint(@Buffer), Count);
end;


Function FileSeek (Handle, Offset, Origin : Longint) : Longint;
var Regs: registers;
begin
Regs.Eax := $4200;
Regs.Al := Origin;
Regs.Edx := Lo(Offset);
Regs.Ecx := Hi(Offset);
Regs.Ebx := Handle;
RealIntr($21, Regs);
if Regs.Flags and CarryFlag <> 0 then
   result := -1
else begin
   LongRec(result).Lo := Regs.Eax;
   LongRec(result).Hi := Regs.Edx;
   end ;
end;


Procedure FileClose (Handle : Longint);
var Regs: registers;
begin
  if Handle<=4 then
   exit;
Regs.Eax := $3e00;
Regs.Ebx := Handle;
RealIntr($21, Regs);
end;

Function FileTruncate (Handle,Size: Longint) : boolean;
var
  regs : trealregs;
begin
  FileSeek(Handle,Size,0);
  Regs.realecx := 0;
  Regs.realedx := tb_offset;
  Regs.ds := tb_segment;
  Regs.ebx := Handle;
  Regs.eax:=$4000;
  RealIntr($21, Regs);
  FileTruncate:=(regs.realflags and carryflag)=0;
end;

Function FileAge (Const FileName : String): Longint;
var Handle: longint;
begin
Handle := FileOpen(FileName, 0);
if Handle <> -1 then begin
   result := FileGetDate(Handle);
   FileClose(Handle);
   end
else result := -1;
end;


Function FileExists (Const FileName : String) : Boolean;
var Handle: longint;
begin
  //!!   This can be done quicker, need to find out how
Result := (OpenFile(FileName, Handle, ofRead, faOpen) = 0);
if Handle <> 0 then
   FileClose(Handle);
end;

Type PSearchrec = ^Searchrec;


Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;

Var Sr : PSearchrec;

begin
//!! Sr := New(PSearchRec);
getmem(sr,sizeof(searchrec));
Rslt.FindHandle := longint(Sr);
DOS.FindFirst(Path, Attr, Sr^);
result := -DosError;
if result = 0 then begin
   Rslt.Time := Sr^.Time;
   Rslt.Size := Sr^.Size;
   Rslt.Attr := Sr^.Attr;
   Rslt.ExcludeAttr := 0;
   Rslt.Name := Sr^.Name;
   end ;
end;


Function FindNext (Var Rslt : TSearchRec) : Longint;

var Sr: PSearchRec;

begin
Sr := PSearchRec(Rslt.FindHandle);
if Sr <> nil then begin
   DOS.FindNext(Sr^);
   result := -DosError;
   if result = 0 then begin
      Rslt.Time := Sr^.Time;
      Rslt.Size := Sr^.Size;
      Rslt.Attr := Sr^.Attr;
      Rslt.ExcludeAttr := 0;
      Rslt.Name := Sr^.Name;
      end ;
   end ;
end;


Procedure FindClose (Var F : TSearchrec);

var Sr: PSearchRec;

begin
Sr := PSearchRec(F.FindHandle);
if Sr <> nil then
  //!! Dispose(Sr);
  freemem(sr,sizeof(searchrec));
F.FindHandle := 0;
end;


Function FileGetDate (Handle : Longint) : Longint;
var Regs: registers;
begin
  //!! for win95 an alternative function is available.
Regs.Ebx := Handle;
Regs.Eax := $5700;
RealIntr($21, Regs);
if Regs.Flags and CarryFlag <> 0 then result := -Regs.Ax
else begin
   LongRec(result).Lo := Regs.cx;
   LongRec(result).Hi := Regs.dx;
   end ;
end;


Function FileSetDate (Handle, Age : Longint) : Longint;
var Regs: registers;
begin
Regs.Ebx := Handle;
Regs.Eax := $5701;
Regs.Ecx := Lo(Age);
Regs.Edx := Hi(Age);
RealIntr($21, Regs);
if Regs.Flags and CarryFlag <> 0 then result := -Regs.Ax
else result := 0;
end;


Function FileGetAttr (Const FileName : String) : Longint;

var Regs: registers;

begin
  StringToTB(FileName);
  Regs.Edx := tb_offset;
  Regs.Ds := tb_segment;
  if LFNSupport then
    begin
    Regs.Ax := $7143;
    Regs.Bx := 0;
    end
  else
    Regs.Ax := $4300;
  RealIntr($21, Regs);
  if Regs.Flags and CarryFlag <> 0 then
    result := -1
  else
    result := Regs.Cx;
end;


Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;

var Regs: registers;

begin
  StringToTB(FileName);
  Regs.Edx := tb_offset;
  Regs.Ds := tb_segment;
  if LFNSupport then
    begin
    Regs.Ax := $7143;
    Regs.Bx := 1;
    end
  else
    Regs.Ax := $4301;
  Regs.Cx := Attr;
  RealIntr($21, Regs);
  if Regs.Flags and CarryFlag <> 0 then result := -Regs.Ax
  else result := 0;
end;


Function DeleteFile (Const FileName : String) : Boolean;

var Regs: registers;

begin
  StringToTB(FileName);
  Regs.Edx := tb_offset;
  Regs.Ds := tb_segment;
  if LFNSupport then
    Regs.Eax := $7141
  else
    Regs.Eax := $4100;
  Regs.Esi := 0;
  Regs.Ecx := 0;
  RealIntr($21, Regs);
  result := (Regs.Flags and CarryFlag = 0);
end;


Function RenameFile (Const OldName, NewName : String) : Boolean;

var Regs: registers;

begin
  StringToTB(OldName + #0 + NewName);
  Regs.Edx := tb_offset;
  Regs.Ds := tb_segment;
  Regs.Edi := tb_offset + Length(OldName) + 1;
  Regs.Es := tb_segment;
  if LFNSupport then
    Regs.Eax := $7156
  else
    Regs.Eax := $5600;
  Regs.Ecx := $ff;
  RealIntr($21, Regs);
  result := (Regs.Flags and CarryFlag = 0);
end;


Function FileSearch (Const Name, DirList : String) : String;

begin
  result := DOS.FSearch(Name, DirList);
end;

Procedure GetLocalTime(var SystemTime: TSystemTime);

var Regs: Registers;

begin
Regs.ah := $2C;
RealIntr($21, Regs);
SystemTime.Hour := Regs.Ch;
SystemTime.Minute := Regs.Cl;
SystemTime.Second := Regs.Dh;
SystemTime.MilliSecond := Regs.Dl;
Regs.ah := $2A;
RealIntr($21, Regs);
SystemTime.Year := Regs.Cx;
SystemTime.Month := Regs.Dh;
SystemTime.Day := Regs.Dl;
end ;

{ ---------------------------------------------------------------------
    Internationalization settings
  ---------------------------------------------------------------------}


{  Codepage constants  }
const
   CP_US = 437;
   CP_MultiLingual = 850;
   CP_SlavicLatin2 = 852;
   CP_Turkish = 857;
   CP_Portugal = 860;
   CP_IceLand = 861;
   CP_Canada = 863;
   CP_NorwayDenmark = 865;

{  CountryInfo   }
type
   TCountryInfo = packed record
      InfoId: byte;
      case integer of
         1: ( Size: word;
              CountryId: word;
              CodePage: word;
              CountryInfo: array[0..33] of byte );
         2: ( UpperCaseTable: longint );
         4: ( FilenameUpperCaseTable: longint );
         5: ( FilecharacterTable: longint );
         6: ( CollatingTable: longint );
         7: ( DBCSLeadByteTable: longint );
   end ;


procedure GetExtendedCountryInfo(InfoId: integer; CodePage, CountryId: word; var CountryInfo: TCountryInfo);

Var Regs: Registers;

begin
  Regs.AH := $65;
  Regs.AL := InfoId;
  Regs.BX := CodePage;
  Regs.DX := CountryId;
  Regs.ES := transfer_buffer div 16;
  Regs.DI := transfer_buffer and 15;
  Regs.CX := SizeOf(TCountryInfo);
  RealIntr($21, Regs);
  DosMemGet(transfer_buffer div 16,
            transfer_buffer and 15,
            CountryInfo, Regs.CX );
end;

procedure InitAnsi;

var CountryInfo: TCountryInfo; i: integer;

begin
{  Fill table entries 0 to 127  }
for i := 0 to 96 do
  UpperCaseTable[i] := chr(i);
for i := 97 to 122 do
  UpperCaseTable[i] := chr(i - 32);
for i := 123 to 127 do
  UpperCaseTable[i] := chr(i);
for i := 0 to 64 do
  LowerCaseTable[i] := chr(i);
for i := 65 to 90 do
  LowerCaseTable[i] := chr(i + 32);
for i := 91 to 255 do
  LowerCaseTable[i] := chr(i);

{  Get country and codepage info  }
GetExtendedCountryInfo(1, $FFFF, $FFFF, CountryInfo);
if CountryInfo.CodePage = 850 then
  begin
  { Special, known case }
  Move(CP850UCT, UpperCaseTable[128], 128);
  Move(CP850LCT, LowerCaseTable[128], 128);
  end
else
  begin
  { this needs to be checked !!
  this is correct only if UpperCaseTable is
  and Offset:Segment word record (PM) }
  {  get the uppercase table from dosmemory  }
  GetExtendedCountryInfo(2, $FFFF, $FFFF, CountryInfo);
  DosMemGet(CountryInfo.UpperCaseTable shr 16, 2 + CountryInfo.UpperCaseTable and 65535, UpperCaseTable[128], 128);
  for i := 128 to 255 do
     begin
     if UpperCaseTable[i] <> chr(i) then
        LowerCaseTable[ord(UpperCaseTable[i])] := chr(i);
     end;
  end;
end;

Procedure InitInternational;

{ This routine is called by the unit startup code. }

begin
  { Init upper/lowercase tables }
  InitAnsi
end;

{
  $Log$
  Revision 1.13  2000-02-17 22:16:05  sg
  * Changed the second argument of FileWrite from "var buffer" to
    "const buffer", like in Delphi.

  Revision 1.12  2000/02/09 16:59:28  peter
    * truncated log

  Revision 1.11  2000/01/16 22:25:38  peter
    * check handle for file closing

  Revision 1.10  2000/01/07 16:41:31  daniel
    * copyright 2000

  Revision 1.9  1999/11/25 15:55:52  pierre
   * web bug 716

  Revision 1.8  1999/08/26 11:02:50  peter
    * findclose freemem fixed

  Revision 1.7  1999/08/24 13:14:28  peter
    * fixed DeleteFile()

  Revision 1.6  1999/08/19 14:00:08  pierre
   * bug in country info code fixed

}