mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-27 19:13:44 +02:00
698 lines
16 KiB
ObjectPascal
698 lines
16 KiB
ObjectPascal
{
|
|
$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.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|