{
Copyright (C) 1998-99 Free Software Foundation, Inc.

Author: Frank Heckenbach <frank@pascal.gnu.de>

Partly BP compatible portable Dos unit

This unit supports some, but not all, of the routines and declarations
of BP's Dos unit. The following routines and declarations are not
supported, and most likely will never be in a portable way, for some
reasons. Note: FindFirst and FindNext are quite inefficient since they
emulate all the brain-dead Dos stuff. If at all possible, the standard
functions OpenDir, ReadDir and CloseDir should be used instead.

Interrupts are Dos and CPU specific:

  type Registers
  constants FCarry, FParity, FAuxiliary, FZero, FSign, FOverflow
  procedure Intr(IntNo: Byte; var Regs: Registers);
  procedure MsDos(var Regs: Registers);
  procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
  procedure SetIntVec(IntNo: Byte; Vector: Pointer);

The format of the return value of this function is Dos specific. Though
most other system have versions numbers as well, returning them here
would usually not do what is expected, e.g. testing if certain Dos
features are present by comparing the version number:

  function DosVersion: Word;

TSR programs are Dos specific:

  procedure Keep(ExitCode: Word);

Changing the system date and time is a system administration task, and
nothing for normal user programs. IOW, these routines simply don't
belong in such a unit:

  procedure SetTime(Hour,Minute,Second,Sec100: Word);
  procedure SetDate(Year,Month,Day: Word);

The CBreak and Verify flags are Dos specific:

  procedure GetCBreak(var Break: Boolean);
  procedure SetCBreak(Break: Boolean);
  procedure GetVerify(var Verify: Boolean);
  procedure SetVerify(Verify: Boolean);

The internal structure of file variables is different in GPC. (As far
as TFDDs are concerned, something compatible on a higher level might
get built into GPC):

  types FileRec, TextRec
  constants fmClosed, fmInput, fmOutput, fmInOut


This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Library General Public License as published by
the Free Software Foundation, version 2.

This library 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.  See the GNU Library General Public
License for more details.

You should have received a copy of the GNU Library General Public License
along with this library; see the file COPYING.LIB.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
MA 02111-1307, USA.
}

{$if __GPC_RELEASE__ < 19981206}
{$error This unit requires GPC release 19981206 or newer}
{$endif}

unit Dos;

interface

uses GPC;

type
  Byte8 = Cardinal (8);
  Int32 = Integer (32);
  TDosAttr = Word;
  GPC_AnyFile = AnyFile; { in order to have AnyFile parameters, while
                           AnyFile is redefined below }

const
  { File attribute constants }
  ReadOnly  = $01;
  Hidden    = $02; { set for dot files except '.' and '..' }
  SysFile   = $04; { not supported }
  VolumeID  = $08; { not supported }
  Directory = $10;
  Archive   = $20; { means: not executable }
  AnyFile   = $3F;

  { DosError codes }
  DosError_FileNotFound = 2;
  DosError_PathNotFound = 3;
  DosError_AccessDenied = 5;
  DosError_InvalidMem   = 9;
  DosErorr_InvalidEnv   = 10;
  DosError_NoMoreFiles  = 18;
  DosError_IOError      = 29;
  DosError_ReadFault    = 30;

type
  { String types. Not used in this unit, but declared for compatibility. }
  ComStr  = String [127];        { Command line string }
  PathStr = String [79];         { File pathname string }
  DirStr  = String [67];         { Drive and directory string }
  NameStr = String [8];          { File name string }
  ExtStr  = String [4];          { File extension string }

  TextBuf = array [0..127] of Char;

  { Search record used by FindFirst and FindNext }
  SearchRecFill = packed array [1..21] of Byte8;
  SearchRec = {$ifdef _Borland_16_Bit_} packed {$endif} record
                Fill : SearchRecFill;
                Attr : Byte8;
                Time : Int32;
                {$ifdef _Borland_16_Bit_}
                Size : Int32;
                Name : String [12]
                {$else}
                Size : LongInt;
                Name : TString
                {$endif}
              end;

  { Date and time record used by PackTime and UnpackTime }
  DateTime = record
               Year, Month, Day, Hour, Min, Sec : Word
             end;

var
  { Error status variable }
  DosError : Integer = 0;

procedure GetDate (var Year, Month, Day, DayOfWeek : Word);
procedure GetTime (var Hour, Minute, Second, Sec100 : Word);
function  DiskFree (Drive : Byte) : LongInt;
function  DiskSize (Drive : Byte) : LongInt;
procedure GetFAttr (var F : GPC_AnyFile; var Attr : TDosAttr);
procedure SetFAttr (var F : GPC_AnyFile; Attr : TDosAttr);
procedure GetFTime (var F : GPC_AnyFile; var Time : Int32);
procedure SetFTime (var F : GPC_AnyFile; Time : Int32);
procedure FindFirst (const Path : String; Attr : TDosAttr; var SR : SearchRec); asmname 'dos_findfirst';
procedure FindNext  (var SR : SearchRec);                                   asmname 'dos_findnext';
procedure FindClose (var SR : SearchRec);                                   asmname 'dos_findclose';
procedure UnpackTime (P : Int32; var T : DateTime);
procedure PackTime (const T : DateTime; var P : Int32);
function  FSearch (const FileName, DirList : String) : TString;             asmname '_p_fsearch';
function  FExpand (const Path : String) : TString;                          asmname '_p_fexpand';
procedure FSplit  (const Path : String; var Dir, Name, Ext : String);       asmname '_p_fsplit';
function  EnvCount : Integer;
function  EnvStr (Index : Integer) : TString;
function  GetEnv (const EnvVar : String) : TString;                         asmname '_p_getenv';
procedure SwapVectors;
procedure Exec (const Path, Params : String);
function  DosExitCode : Word;

{ Extensions }

var
  { The following variables can be set to routines that are called before
    or after an Exec call. Used e.g. by CRT to tell curses about the change.
    They're initialized to SwapVectors which does nothing. }
  InitExec : procedure = SwapVectors;
  DoneExec : procedure = SwapVectors;

implementation

{$B-,I-}

type
  PLongInt = ^LongInt;

var
  DosExitCodeVar : Word = 0;

{$L dosc.c}
function Dos_SetFAttr (FileName : CString; Writable, Executable : Boolean) : Integer; C;

procedure GetDate (var Year, Month, Day, DayOfWeek : Word);
var t : TimeStamp;
begin
  GetTimeStamp (t);
  Year      := t.Year;
  Month     := t.Month;
  Day       := t.Day;
  DayOfWeek := t.DayOfWeek
end;

procedure GetTime (var Hour, Minute, Second, Sec100 : Word);
var t : TimeStamp;
begin
  GetTimeStamp (t);
  Hour   := t.Hour;
  Minute := t.Minute;
  Second := t.Second;
  Sec100 := t.MicroSecond div 10000
end;

function DiskFree (Drive : Byte) : LongInt;
var
  Path : String (2);
  Buf : StatFSBuffer;
begin
  if Drive = 0
    then Path := DirSelf
    else
      begin
        Path := 'a:';
        Inc (Path [1], Drive - 1)
      end;
  StatFS (Path, Buf);
  if IOResult = 0
    then DiskFree := Buf.BlockSize * Buf.BlocksFree
    else
      begin
        DosError := DosError_AccessDenied;
        DiskFree := -1
      end
end;

function DiskSize (Drive : Byte) : LongInt;
var
  Path : String (2);
  Buf : StatFSBuffer;
begin
  if Drive = 0
    then Path := DirSelf
    else
      begin
        Path := 'a:';
        Inc (Path [1], Drive - 1)
      end;
  StatFS (Path, Buf);
  if IOResult = 0
    then DiskSize := Buf.BlockSize * Buf.BlocksTotal
    else
      begin
        DosError := DosError_AccessDenied;
        DiskSize := -1
      end
end;

procedure GetFAttr (var F : GPC_AnyFile; var Attr : TDosAttr);
var
  b : BindingType;
  s : TString;
  d : Integer;
begin
  b := Binding (F);
  Attr := 0;
  if not (b.Bound and (b.Existing or b.Directory))
    then DosError := DosError_FileNotFound
    else
      begin
        DosError := 0;
        if b.Directory      then Attr := Attr or Directory;
        if not b.Writable   then Attr := Attr or ReadOnly;
        if not b.Executable then Attr := Attr or Archive;
        d := Length (b.Name);
        while (d > 0) and not (b.Name [d] in DirSeparators) do Dec (d);
        if (Length (b.Name) > d + 1) and (b.Name [d + 1] =  '.') and
          ((Length (b.Name) > d + 2) or  (b.Name [d + 2] <> '.')) then
          Attr := Attr or Hidden
      end
end;

procedure SetFAttr (var F : GPC_AnyFile; Attr : TDosAttr);
var b : BindingType;
begin
  b := Binding (F);
  if not b.Bound
    then DosError := DosError_FileNotFound
    else DosError := Dos_SetFAttr (b.Name, Attr and ReadOnly = 0, Attr and Archive = 0)
end;

procedure GetFTime_Size (var F : GPC_AnyFile; var Time : Int32; PSize : PLongInt);
var
  b : BindingType;
  Year, Month, Day, Hour, Minute, Second : Integer;
  dt : DateTime;
begin
  b := Binding (F);
  if not b.Bound
    then DosError := DosError_FileNotFound
    else
      begin
        UnixTimeToTime (b.ModificationTime, Year, Month, Day, Hour, Minute, Second);
        dt.Year  := Year;
        dt.Month := Month;
        dt.Day   := Day;
        dt.Hour  := Hour;
        dt.Min   := Minute;
        dt.Sec   := Second;
        PackTime (dt, Time);
        if PSize <> nil then PSize^ := b.Size;
        DosError := 0
      end
end;

procedure GetFTime (var F : GPC_AnyFile; var Time : Int32);
begin
  GetFTime_Size (F, Time, nil)
end;

procedure SetFTime (var F : GPC_AnyFile; Time : Int32);
var
  dt : DateTime;
  ut: UnixTimeType;
begin
  UnpackTime (Time, dt);
  with dt do ut := TimeToUnixTime (Year, Month, Day, Hour, Min, Sec);
  DosError := DosError_AccessDenied;
  if ut >= 0 then
    begin
      SetFileTime (F, ut);
      if IOResult = 0 then DosError := 0
    end
end;

{ Since there's no explicit closing of FindFirst/FindNext, FindList keeps
  tracks of all running searches so they can be closed automatically when
  necessary, and Magic indicates if a SearchRec is currently in use. }

const
  srOpened = $2424D00F;
  srDone   = $4242F00D;

type
  TSRFillInternal = packed record
    Magic  : Integer;
    Unused : packed array [1..SizeOf (SearchRecFill) - SizeOf (Integer)] of Byte
  end;

  PPFindList = ^PFindList;
  PFindList  = ^TFindList;
  TFindList  = record
    Next : PFindList;
    SR   : ^SearchRec;
    Dir,
    Name,
    Ext  : TString;
    Attr : TDosAttr;
    PDir : Pointer;
  end;

var FindList : PFindList = nil;

function CloseFind (PTemp : PPFindList) : Integer;
var Temp : PFindList;
begin
  Temp := PTemp^;
  CloseFind := CloseDir (Temp^.PDir);
  TSRFillInternal (Temp^.SR^.Fill).Magic := srDone;
  PTemp^ := Temp^.Next;
  Dispose (Temp)
end;

procedure FindFirst (const Path : String; Attr : TDosAttr; var SR : SearchRec);
var
  Name, Ext : TString;
  Temp : PFindList;
  PTemp : PPFindList;
begin
  { If SR was used before, close that usage }
  PTemp := @FindList;
  while (PTemp^ <> nil) and (PTemp^^.SR <> @SR) do PTemp := @PTemp^^.Next;
  if PTemp^ <> nil then DosError := CloseFind (PTemp);
  if Attr and not (ReadOnly or Archive) = VolumeID then
    begin
      DosError := DosError_NoMoreFiles;
      Exit
    end;
  New (Temp);
  FSplit (Path, Temp^.Dir, Name, Ext);
  if Temp^.Dir = '' then Temp^.Dir := DirSelf + DirSeparator;
  Temp^.SR := @SR;
  Temp^.Name := Name;
  Temp^.Ext  := Ext;
  Temp^.Attr := Attr;
  Temp^.PDir := OpenDir (Temp^.Dir);
  if Temp^.PDir = nil then
    begin
      TSRFillInternal (SR.Fill).Magic := srDone;
      Dispose (Temp);
      DosError := DosError_NoMoreFiles;
      Exit
    end;
  TSRFillInternal (SR.Fill).Magic := srOpened;
  Temp^.Next := FindList;
  FindList := Temp;
  FindNext (SR)
end;

procedure FindNext (var SR : SearchRec);
var
  Temp : PFindList;
  PTemp : PPFindList;
  Name, Dir, Nam, Ext : TString;
  F : Text;
  TmpAttr : TDosAttr;
  TmpSize : LongInt;
  TmpTime : Int32;

  { Emulate Dos brain-damaged file name wildcard matching }
  function MatchPart (const Name, Mask : String) : Boolean;
  var c : Integer;
  begin
    for c := 1 to Length (Mask) do
      case Mask [c] of
        '?' : ;
        '*' : return True;
        else
          if (c > Length (Name)) or (Name [c] <> Mask [c]) then return False
      end;
    MatchPart := Length (Mask) >= Length (Name)
  end;

begin
  DosError := 0;
  { Check if SR is still valid }
  case TSRFillInternal (SR.Fill).Magic of
    srOpened : ;
    srDone   : begin
                 DosError := DosError_NoMoreFiles;
                 Exit
               end;
    else
      DosError := DosError_InvalidMem;
      Exit
  end;
  PTemp := @FindList;
  while (PTemp^ <> nil) and (PTemp^^.SR <> @SR) do PTemp := @PTemp^^.Next;
  Temp := PTemp^;
  if Temp = nil then
    begin
      DosError := DosError_InvalidMem;
      Exit
    end;
  repeat
    Name := ReadDir (Temp^.PDir);
    if Name = '' then
      begin
        if CloseFind (PTemp) = 0
          then DosError := DosError_NoMoreFiles
          else DosError := DosError_ReadFault;
        Exit
      end;
    Assign (F, Temp^.Dir + Name);
    GetFAttr (F, TmpAttr);
    SR.Attr := TmpAttr;
    FSplit (Name, Dir, Nam, Ext);
    if Ext = '' then Ext := ExtSeparator
  until MatchPart (Nam, Temp^.Name) and MatchPart (Ext, Temp^.Ext) and
        { Emulate Dos brain-damaged file attribute matching }
        ((Temp^.Attr and (Hidden or SysFile) <> 0) or (TmpAttr and Hidden    = 0)) and
        ((Temp^.Attr and Directory           <> 0) or (TmpAttr and Directory = 0));
  SR.Name := Name;
  if DosError <> 0 then Exit;
  GetFTime_Size (F, TmpTime, @TmpSize);
  SR.Time := TmpTime;
  SR.Size := TmpSize
end;

procedure FindClose (var SR : SearchRec);
var PTemp : PPFindList;
begin
  PTemp := @FindList;
  while (PTemp^ <> nil) and (PTemp^^.SR <> @SR) do PTemp := @PTemp^^.Next;
  if (PTemp^ <> nil) and (CloseFind (PTemp) <> 0) then DosError := DosError_ReadFault
end;

type
  DosTime = packed record
    DSec  : Cardinal (5);
    Min   : Cardinal (6);
    Hour  : Cardinal (5);
    Day   : Cardinal (5);
    Month : Cardinal (4);
    Year  : Integer  (7)  { Integer  (7) yields valid years 1916..2043;
                            Cardinal (7) would yield 1980..2107 }
  end;

procedure UnpackTime (P : Int32; var T : DateTime);
begin
  with DosTime (p) do
    begin
      T.Year  := Year + 1980;
      T.Month := Month;
      T.Day   := Day;
      T.Hour  := Hour;
      T.Min   := Min;
      T.Sec   := DSec * 2
    end
end;

procedure PackTime (const T : DateTime; var P : Int32);
begin
  with DosTime (p) do
    begin
      Year  := T.Year - 1980;
      Month := T.Month;
      Day   := T.Day;
      Hour  := T.Hour;
      Min   := T.Min;
      DSec  := T.Sec div 2
    end
end;

function EnvCount : Integer;
var i : Integer;
begin
  i := 0;
  while Environment^[i] <> nil do Inc (i);
  EnvCount := i
end;

function EnvStr (Index : Integer) : TString;
begin
  if (Index < 1) or (Index > EnvCount)
    then EnvStr := ''
    else EnvStr := CString2String (Environment^[Index - 1])
end;

procedure SwapVectors;
begin
  { Nothing to be done }
end;

procedure Exec (const Path, Params : String);
begin
  InitExec;
  DosExitCodeVar := Execute (Path + ' ' + Params);
  if IOResult <> 0 then DosError := DosError_FileNotFound;
  DoneExec
end;

function DosExitCode : Word;
begin
  DosExitCode := DosExitCodeVar
end;

end.
