freepascal.compiler/rtl/beos/dos.pp

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

    Dos unit for BP7 compatible RTL

    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.

 **********************************************************************}
unit dos;
interface

uses beos;

const
  FileNameLen=255;

type
  ComStr  = String[FileNameLen];
  PathStr = String[FileNameLen];
  DirStr  = String[FileNameLen];
  NameStr = String[FileNameLen];
  ExtStr  = String[FileNameLen];


Const
  LFNSUPPORT=True;

  {Bitmasks for CPU Flags}
  fcarry     = $0001;
  fparity    = $0004;
  fauxiliary = $0010;
  fzero      = $0040;
  fsign      = $0080;
  foverflow  = $0800;

  {Bitmasks for file attribute}
  readonly  = $01;
  hidden    = $02;
  sysfile   = $04;
  volumeid  = $08;
  directory = $10;
  archive   = $20;
  anyfile   = $3F;

  {File Status}
  fmclosed = $D7B0;
  fminput  = $D7B1;
  fmoutput = $D7B2;
  fminout  = $D7B3;


  S_IFMT  = $F000; { type of file }
  S_IFLNK = $A000; { symbolic link }
  S_IFREG =     $8000; { regular }
  S_IFBLK =     $6000; { block special }
  S_IFDIR =     $4000; { directory }
  S_IFCHR =     $2000; { character special }
  S_IFIFO =     $1000; { fifo }

{
  filerec.inc contains the definition of the filerec.
  textrec.inc contains the definition of the textrec.
  It is in a separate file to make it available in other units without
  having to use the DOS unit for it.
}
{$i filerec.inc}
{$i textrec.inc}

  DateTime = packed record
    Year,
    Month,
    Day,
    Hour,
    Min,
    Sec   : word;
  End;

  searchrec = record
     fd       : longint;
     path     : string;
     fname    : string;
     attr     : byte;
     time     : longint;
     size     : longint;
     name     : string[255];
  end;


Var
  DosError : integer;

{Info/Date/Time}
Procedure GetDate(var year, month, mday, wday: word);
procedure GetTime(var hour,min,sec,msec,usec:word);
procedure GetTime(var hour,min,sec,sec100:word);
procedure GetTime(Var Hour,Min,Sec:Word);

Procedure UnpackTime(p: longint; var t: datetime);
Procedure PackTime(var t: datetime; var p: longint);

{Exec}
Procedure Exec(const path: pathstr; const comline: comstr);
Function  DosExitCode: word;


{Disk}
Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
Procedure FindNext(var f: searchRec);
Procedure FindClose(var f: searchRec);

{File}
{Procedure GetFAttr(var f:File; var attr: word);}
procedure GetFTime(var f:File; var time: longint);
procedure GetFTime(f:string; var time: longint);
Procedure SetFTime(var f:File; time : longint);
Function  FSearch(path: pathstr; dirlist: string): pathstr;
Function  FExpand(const path: pathstr): pathstr;
Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);




{Environment}
{Function  EnvCount: longint;
Function  EnvStr(index: integer): string;}

{Misc}
{Procedure SetFAttr(var f; attr: word);
Procedure SetFTime(var f; time: longint);
Procedure GetVerify(var verify: boolean);
Procedure SetVerify(verify: boolean);}

{Do Nothing Functions}
Procedure SwapVectors;
{Procedure GetIntVec(intno: byte; var vector: pointer);
Procedure SetIntVec(intno: byte; vector: pointer);
Procedure Keep(exitcode: word);}
function GetEnv(EnvVar: String): String;


Procedure EpochToLocal(epoch:longint;var year,month,day,hour,minute,second:Word);


implementation

uses strings;


procedure GetFTime(var f:file; var time: longint);
var info:stat;
    t:longint;
    dt:DateTime;
begin
  if not FStat(F,Info) then begin
    t:=0;
    doserror:=3;
    exit;
  end else t:=info.ctime;
  EpochToLocal(t,dt.year,dt.month,dt.day,dt.hour,dt.min,dt.sec);
  packtime(dt,time);
end;

procedure GetFTime(f:string; var time: longint);
var info:stat;
    t:longint;
    dt:DateTime;
begin
  if not FStat(F,Info) then begin
    t:=0;
    doserror:=3;
    exit;
  end else t:=info.ctime;
  EpochToLocal(t,dt.year,dt.month,dt.day,dt.hour,dt.min,dt.sec);
  packtime(dt,time);
end;


type utimbuf=record actime,modtime:longint; end;
{function _utime (path:pchar;var buf:utimbuf):longint; cdecl; external name 'utime';}

Procedure setftime(var f:file; time : longint);
{var buf:utimbuf;}
begin
{  buf.actime:=time;
  buf.modtime:=time;}
{  writeln ('SetFTime ',PChar(@FileRec(f).Name),' := ',time);}
{  if _utime(PChar(@FileRec(f).Name),buf)<>0 then doserror:=3;}
end;


{******************************************************************************
                        --- Info / Date / Time ---
******************************************************************************}


procedure getdate(var year,month,mday,wday : word);
begin
end;

function sys_time:longint; cdecl; external name 'sys_time';


procedure GetTime(var hour,min,sec,msec,usec:word);
{
  Gets the current time, adjusted to local time
}
var
  year,day,month:Word;
  t : longint;
begin
  t:=sys_time;
  EpochToLocal(t,year,month,day,hour,min,sec);
  msec:=0;
  usec:=0;
end;

procedure GetTime(var hour,min,sec,sec100:word);
{ Gets the current time, adjusted to local time }
var usec : word;
begin
  gettime(hour,min,sec,sec100,usec);
  sec100:=sec100 div 10;
end;

procedure GetTime(Var Hour,Min,Sec:Word);
{
  Gets the current time, adjusted to local time
  }
  var
    msec,usec : Word;
    Begin
      gettime(hour,min,sec,msec,usec);
end;



Procedure packtime(var t : datetime;var p : longint);
Begin
  p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
End;


Procedure unpacktime(p : longint;var t : datetime);
Begin
  with t do
   begin
     sec:=(p and 31) shl 1;
     min:=(p shr 5) and 63;
     hour:=(p shr 11) and 31;
     day:=(p shr 16) and 31;
     month:=(p shr 21) and 15;
     year:=(p shr 25)+1980;
   end;
End;


{******************************************************************************
                               --- Exec ---
******************************************************************************}


Procedure Exec(const path: pathstr; const comline: comstr);
var p:string;
begin
  p:=path+' '+comline;
  doserror:=beos.shell(p);
end;

Function DosExitCode: word;
begin
    dosexitcode:=doserror;
end;




{******************************************************************************
                               --- File ---
******************************************************************************}

Procedure FSplit(Path: PathStr; Var Dir: DirStr; Var Name: NameStr;Var Ext: ExtStr);

Begin
  beos.FSplit(Path,Dir,Name,Ext);
End;

Function FExpand(Const Path: PathStr): PathStr;
Begin
  FExpand:=beos.FExpand(Path);
End;

Function FSearch(path : pathstr;dirlist : string) : pathstr;
Var info:stat;
Begin
if (length(Path)>0) and (path[1]='/') and FStat(path,info) then
    FSearch:=path
  else
      FSearch:=beos.FSearch(path,dirlist);
End;



{******************************************************************************
                     --- Findfirst FindNext ---
******************************************************************************}

{procedure dossearchrec2searchrec(var f : searchrec);
var
  len : longint;
begin
  len:=StrLen(@f.Name);
  Move(f.Name[0],f.Name[1],Len);
  f.Name[0]:=chr(len);
end;}

type dirent = packed record
        d_dev:longint;
        d_pdev:longint;
        d_ino:int64;
        d_pino:int64;
        d_reclen:word;
        d_name:array[0..255] of char;
end;

function sys_opendir (a:dword;path:pchar;b:longint):longint; cdecl; external name 'sys_opendir';
function sys_readdir (fd:longint;var de:dirent;a:longint;b:byte):longint; cdecl; external name 'sys_readdir';

procedure findnext(var f : searchRec);
var len:longint;
    ent:dirent;
    info:stat;
    dt:DateTime;
begin
   if sys_readdir(f.fd,ent,$11C,1)=0 then begin
    doserror:=3;
    exit;
  end;
{   writeln ('NAME: ',pchar(@ent.d_name[0]));}

  len:=StrLen(@ent.d_name);
  Move(ent.d_name,f.name[1],len);
  f.name[0]:=chr(len);
{  writeln ('NAME: "',f.path+f.name,'"');}

  if not FStat(f.path+f.name,info) then begin
    writeln ('NOT FOUND');
    doserror:=3;
    exit;
  end;
  writeln ('OK');

  f.size:=info.size;

  f.attr:=0;
  if (info.mode and S_IFMT)=S_IFDIR then f.attr:=directory;

  EpochToLocal(info.mtime,dt.year,dt.month,dt.day,dt.hour,dt.min,dt.sec);
  packtime(dt,f.time);
  doserror:=0;

end;


procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
var tmp:string;
    info:stat;
    ext:string;
begin
  tmp:=path;
  if tmp='' then tmp:='.';

  if FStat(tmp,info) then begin
    if ((info.mode and S_IFMT)=S_IFDIR) and (tmp[length(tmp)]<>'/') then tmp:=tmp+'/';
  end;

  FSplit (tmp,f.path,f.fname,ext);
{  f.path:=FExpand(f.path);}
  f.fname:=f.fname+ext;
  if length(f.fname)=0 then f.fname:='*';

  tmp:=tmp+#0;
  f.fd:=sys_opendir ($FF000000,@tmp[1],0);
  writeln ('F.PATH=',f.path,'   ;   ',f.fname);
  findnext(f);
end;

Procedure FindClose(Var f: SearchRec);
begin
  DosError:=0;
end;


procedure swapvectors;
begin
{ no beos equivalent }
  DosError:=0;
end;



{******************************************************************************
                             --- Environment ---
******************************************************************************}

function envcount : longint;
var
  hp : ppchar;
begin
  hp:=envp;
  envcount:=0;
  while assigned(hp^) do
   begin
     inc(envcount);
     hp:=hp+4;
   end;
end;


function envstr(index : integer) : string;
begin
  if (index<=0) or (index>envcount) then
   begin
     envstr:='';
     exit;
   end;
  envstr:=strpas(ppchar(envp+4*(index-1))^);
end;


{******************************************************************************
                             --- Not Supported ---
******************************************************************************}

Procedure keep(exitcode : word);
Begin
End;

Procedure getintvec(intno : byte;var vector : pointer);
Begin
End;

Procedure setintvec(intno : byte;vector : pointer);
Begin
End;




{******************************************************************************
                       Date and Time related calls
******************************************************************************}

Const
{Date Translation}
  C1970=2440588;
  D0   =   1461;
  D1   = 146097;
  D2   =1721119;

Procedure JulianToGregorian(JulianDN:LongInt;Var Year,Month,Day:Word);
Var
  YYear,XYear,Temp,TempMonth : LongInt;
Begin
  Temp:=((JulianDN-D2) shl 2)-1;
  JulianDN:=Temp Div D1;
  XYear:=(Temp Mod D1) or 3;
  YYear:=(XYear Div D0);
  Temp:=((((XYear mod D0)+4) shr 2)*5)-3;
  Day:=((Temp Mod 153)+5) Div 5;
  TempMonth:=Temp Div 153;
  If TempMonth>=10 Then
  Begin
    inc(YYear);
    dec(TempMonth,12);
  End;
  inc(TempMonth,3);
  Month := TempMonth;
  Year:=YYear+(JulianDN*100);
end;


Procedure EpochToLocal(epoch:longint;var year,month,day,hour,minute,second:Word);
{ Transforms Epoch time into local time (hour, minute,seconds) }
Var
  DateNum: LongInt;
Begin
  Datenum:=(Epoch Div 86400) + c1970;
  JulianToGregorian(DateNum,Year,Month,day);
  Epoch:=Epoch Mod 86400;
  Hour:=Epoch Div 3600;
  Epoch:=Epoch Mod 3600;
  Minute:=Epoch Div 60;
  Second:=Epoch Mod 60;
End;


{
  $Log$
  Revision 1.1  2001-06-02 19:26:03  peter
    * BeOS target!

  Revision 1.5  2000/01/07 16:41:29  daniel
    * copyright 2000

  Revision 1.4  2000/01/07 16:32:23  daniel
    * copyright 2000 added

  Revision 1.3  1999/01/22 16:22:09  pierre
   * Daniel removal of findclose reverted

  Revision 1.2  1999/01/22 10:07:02  daniel
  - Findclose removed: This is TP incompatible!!

  Revision 1.1  1998/12/21 13:07:02  peter
    * use -FE

  Revision 1.19  1998/11/23 13:53:59  peter
    * more fexpand fixes from marco van de voort

  Revision 1.18  1998/11/23 12:48:02  peter
    * fexpand('o:') fixed to return o:\ (from the mailinglist)

  Revision 1.17  1998/11/22 09:33:21  florian
    * fexpand bug (temp. strings were too shoort) fixed, was reported
      by Marco van de Voort

  Revision 1.16  1998/11/17 09:37:41  pierre
   * explicit conversion from word dosreg.ax to integer doserror

  Revision 1.15  1998/11/01 20:27:18  peter
    * fixed some doserror settings

  Revision 1.14  1998/10/22 15:05:28  pierre
   * fsplit adapted to long filenames

  Revision 1.13  1998/09/16 16:47:24  peter
    * merged fixes

  Revision 1.11.2.2  1998/09/16 16:16:04  peter
    * go32v1 compiles again

  Revision 1.12  1998/09/11 12:46:44  pierre
    * range check problem with LFN attr removed

  Revision 1.11.2.1  1998/09/11 12:38:41  pierre
    * conversion from LFN attr to Dos attr did not respect range checking

  Revision 1.11  1998/08/28 10:45:58  peter
    * fixed path buffer in findfirst

  Revision 1.10  1998/08/27 10:30:48  pierre
    * go32v1 RTL did not compile (LFNsupport outside go32v2 defines !)
      I renamed tb_selector to tb_segment because
        it is a real mode segment as opposed to
        a protected mode selector
      Fixed it for go32v1 (remove the $E0000000 offset !)

  Revision 1.9  1998/08/26 10:04:01  peter
    * new lfn check from mailinglist
    * renamed win95 -> LFNSupport
    + tb_selector, tb_offset for easier access to transferbuffer

  Revision 1.8  1998/08/16 20:39:49  peter
    + LFN Support

  Revision 1.7  1998/08/16 09:12:13  michael
  Corrected fexpand behaviour.

  Revision 1.6  1998/08/05 21:01:50  michael
  applied bugfix from maillist to fsearch

  Revision 1.5  1998/05/31 14:18:13  peter
    * force att or direct assembling
    * cleanup of some files

  Revision 1.4  1998/05/22 00:39:22  peter
    * go32v1, go32v2 recompiles with the new objects
    * remake3 works again with go32v2
    - removed some "optimizes" from daniel which were wrong

  Revision 1.3  1998/05/21 19:30:47  peter
    * objects compiles for linux
    + assign(pchar), assign(char), rename(pchar), rename(char)
    * fixed read_text_as_array
    + read_text_as_pchar which was not yet in the rtl
}



Function StringToPPChar(Var S:STring):ppchar;
{
  Create a PPChar to structure of pchars which are the arguments specified
  in the string S. Especially usefull for creating an ArgV for Exec-calls
}
var
  nr  : longint;
  Buf : ^char;
  p   : ppchar;
begin
  s:=s+#0;
  buf:=@s[1];
  nr:=0;
  while(buf^<>#0) do
   begin
     while (buf^ in [' ',#8,#10]) do
      inc(buf);
     inc(nr);
     while not (buf^ in [' ',#0,#8,#10]) do
      inc(buf);
   end;
  getmem(p,nr*4);
  StringToPPChar:=p;
  if p=nil then
   begin
{     LinuxError:=sys_enomem;}
     exit;
   end;
  buf:=@s[1];
  while (buf^<>#0) do
   begin
     while (buf^ in [' ',#8,#10]) do
      begin
        buf^:=#0;
        inc(buf);
      end;
     p^:=buf;
     inc(p);
     p^:=nil;
     while not (buf^ in [' ',#0,#8,#10]) do
      inc(buf);
   end;
end;



Function Dirname(Const path:pathstr):pathstr;
{
  This function returns the directory part of a complete path.
  Unless the directory is root '/', The last character is not
  a slash.
}
var
  Dir  : PathStr;
  Name : NameStr;
  Ext  : ExtStr;
begin
  FSplit(Path,Dir,Name,Ext);
  if length(Dir)>1 then
   Delete(Dir,length(Dir),1);
  DirName:=Dir;
end;



Function Basename(Const path:pathstr;Const suf:pathstr):pathstr;
{
  This function returns the filename part of a complete path. If suf is
  supplied, it is cut off the filename.
}
var
  Dir  : PathStr;
  Name : NameStr;
  Ext  : ExtStr;
begin
  FSplit(Path,Dir,Name,Ext);
  if Suf<>Ext then
   Name:=Name+Ext;
  BaseName:=Name;
end;


function GetEnv(EnvVar: String): String;
var p:pchar;
begin
  p:=beos.GetEnv(EnvVar);
  if p=nil then
    GetEnv:=''
  else
    GetEnv:=StrPas(p);
end;


end.