mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 15:49:27 +02:00
- remove $IFDEF DELPHI and related code
- remove $IFDEF FPCPROCVAR and related code
This commit is contained in:
mazen
parent
ad191865e3
commit
3b092352e1
@ -1,859 +0,0 @@
|
||||
{
|
||||
$Id$
|
||||
Copyright (c) 1998-2002 by Florian Klaempfl
|
||||
|
||||
Dos unit for BP7 compatible RTL for Delphi
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation; either version 2 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
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. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
|
||||
****************************************************************************
|
||||
}
|
||||
unit dmisc;
|
||||
|
||||
{$i fpcdefs.inc}
|
||||
|
||||
interface
|
||||
|
||||
{$ifndef linux}
|
||||
{$define MSWindows}
|
||||
{$endif}
|
||||
|
||||
uses
|
||||
{$ifdef linux}
|
||||
Libc,
|
||||
{$else}
|
||||
windows,
|
||||
{$endif}
|
||||
sysutils;
|
||||
|
||||
|
||||
Const
|
||||
Max_Path = 255;
|
||||
|
||||
{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;
|
||||
|
||||
|
||||
Type
|
||||
DWord = Cardinal;
|
||||
qword = int64;
|
||||
tlongint = array[0..65535] of longint;
|
||||
plongintarray = ^tlongint;
|
||||
|
||||
{ Needed for Win95 LFN Support }
|
||||
ComStr = String[255];
|
||||
PathStr = String[255];
|
||||
DirStr = String[255];
|
||||
NameStr = String[255];
|
||||
ExtStr = String[255];
|
||||
|
||||
FileRec = TFileRec;
|
||||
|
||||
DateTime = packed record
|
||||
Year,
|
||||
Month,
|
||||
Day,
|
||||
Hour,
|
||||
Min,
|
||||
Sec : word;
|
||||
End;
|
||||
|
||||
SearchRec = Sysutils.TSearchRec;
|
||||
|
||||
registers = packed record
|
||||
case i : integer of
|
||||
0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
|
||||
1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
|
||||
2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
|
||||
end;
|
||||
|
||||
Var
|
||||
DosError : integer;
|
||||
|
||||
{Interrupt}
|
||||
Procedure Intr(intno: byte; var regs: registers);
|
||||
Procedure MSDos(var regs: registers);
|
||||
|
||||
{Info/Date/Time}
|
||||
Function DosVersion: Word;
|
||||
Procedure GetDate(var year, month, mday, wday: word);
|
||||
Procedure GetTime(var hour, minute, second, sec100: 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}
|
||||
Function DiskFree(drive: byte) : int64;
|
||||
Function DiskSize(drive: byte) : int64;
|
||||
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; var attr: word);
|
||||
Procedure GetFTime(var f; var tim: 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;
|
||||
Function GetEnv(envvar: string): string;
|
||||
|
||||
{Misc}
|
||||
Procedure SetFAttr(var f; attr: word);
|
||||
Procedure SetFTime(var f; time: longint);
|
||||
Procedure GetCBreak(var breakvalue: boolean);
|
||||
Procedure SetCBreak(breakvalue: boolean);
|
||||
Procedure GetVerify(var verify: boolean);
|
||||
Procedure SetVerify(verify: boolean);
|
||||
|
||||
{Memory}
|
||||
function CompareByte(const buf1,buf2;len:longint):longint;
|
||||
|
||||
{Do Nothing Functions}
|
||||
Procedure SwapVectors;
|
||||
Procedure GetIntVec(intno: byte; var vector: pointer);
|
||||
Procedure SetIntVec(intno: byte; vector: pointer);
|
||||
Procedure Keep(exitcode: word);
|
||||
|
||||
implementation
|
||||
|
||||
function CompareByte(const buf1,buf2;len:longint):longint;
|
||||
begin
|
||||
{ Both buffers are similar }
|
||||
if comparemem(@buf1, @buf2, len) then
|
||||
CompareByte := 0
|
||||
else
|
||||
CompareByte := 1;
|
||||
end;
|
||||
|
||||
|
||||
function upper(const s : string) : string;
|
||||
{
|
||||
return uppercased string of s
|
||||
}
|
||||
var
|
||||
i : longint;
|
||||
begin
|
||||
for i:=1 to length(s) do
|
||||
if s[i] in ['a'..'z'] then
|
||||
upper[i]:=char(byte(s[i])-32)
|
||||
else
|
||||
upper[i]:=s[i];
|
||||
upper[0]:=s[0];
|
||||
end;
|
||||
|
||||
{******************************************************************************
|
||||
--- Conversion ---
|
||||
******************************************************************************}
|
||||
|
||||
{$ifdef MSWindows}
|
||||
function GetLastError : DWORD;stdcall;
|
||||
external 'Kernel32.dll' name 'GetLastError';
|
||||
function FileTimeToDosDateTime(const ft :TFileTime;var data,time : word) : boolean;stdcall;
|
||||
external 'Kernel32.dll' name 'FileTimeToDosDateTime';
|
||||
function DosDateTimeToFileTime(date,time : word;var ft :TFileTime) : boolean;stdcall;
|
||||
external 'Kernel32.dll' name 'DosDateTimeToFileTime';
|
||||
function FileTimeToLocalFileTime(const ft : TFileTime;var lft : TFileTime) : boolean;stdcall;
|
||||
external 'Kernel32.dll' name 'FileTimeToLocalFileTime';
|
||||
function LocalFileTimeToFileTime(const lft : TFileTime;var ft : TFileTime) : boolean;stdcall;
|
||||
external 'Kernel32.dll' name 'LocalFileTimeToFileTime';
|
||||
|
||||
type
|
||||
Longrec=packed record
|
||||
lo,hi : word;
|
||||
end;
|
||||
|
||||
function Last2DosError(d:dword):integer;
|
||||
begin
|
||||
Last2DosError:=d;
|
||||
end;
|
||||
|
||||
|
||||
Function DosToWinAttr (Const Attr : Longint) : longint;
|
||||
begin
|
||||
DosToWinAttr:=Attr;
|
||||
end;
|
||||
|
||||
|
||||
Function WinToDosAttr (Const Attr : Longint) : longint;
|
||||
begin
|
||||
WinToDosAttr:=Attr;
|
||||
end;
|
||||
|
||||
|
||||
Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):boolean;
|
||||
var
|
||||
lft : TFileTime;
|
||||
begin
|
||||
DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and
|
||||
LocalFileTimeToFileTime(lft,Wtime);
|
||||
end;
|
||||
|
||||
|
||||
Function WinToDosTime (Const Wtime : TFileTime;var DTime:longint):boolean;
|
||||
var
|
||||
lft : TFileTime;
|
||||
begin
|
||||
WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
|
||||
FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
|
||||
{******************************************************************************
|
||||
--- Dos Interrupt ---
|
||||
******************************************************************************}
|
||||
|
||||
procedure intr(intno : byte;var regs : registers);
|
||||
begin
|
||||
{ !!!!!!!! }
|
||||
end;
|
||||
|
||||
procedure msdos(var regs : registers);
|
||||
begin
|
||||
{ !!!!!!!! }
|
||||
end;
|
||||
|
||||
|
||||
{******************************************************************************
|
||||
--- Info / Date / Time ---
|
||||
******************************************************************************}
|
||||
|
||||
function dosversion : word;
|
||||
begin
|
||||
dosversion:=0;
|
||||
end;
|
||||
|
||||
|
||||
procedure getdate(var year,month,mday,wday : word);
|
||||
begin
|
||||
DecodeDate(Now,Year,Month,MDay);
|
||||
WDay:=0;
|
||||
// DecodeDateFully(Now,Year,Month,MDay,WDay);
|
||||
end;
|
||||
|
||||
|
||||
procedure gettime(var hour,minute,second,sec100 : word);
|
||||
begin
|
||||
DecodeTime(Now,Hour,Minute,Second,Sec100);
|
||||
Sec100:=Sec100 div 10;
|
||||
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 ---
|
||||
******************************************************************************}
|
||||
var
|
||||
lastdosexitcode : word;
|
||||
|
||||
{$ifdef MSWindows}
|
||||
procedure exec(const path : pathstr;const comline : comstr);
|
||||
var
|
||||
SI: TStartupInfo;
|
||||
PI: TProcessInformation;
|
||||
Proc : THandle;
|
||||
l : DWord;
|
||||
AppPath,
|
||||
AppParam : array[0..255] of char;
|
||||
begin
|
||||
FillChar(SI, SizeOf(SI), 0);
|
||||
SI.cb:=SizeOf(SI);
|
||||
SI.wShowWindow:=1;
|
||||
Move(Path[1],AppPath,length(Path));
|
||||
AppPath[Length(Path)]:=#0;
|
||||
AppParam[0]:='-';
|
||||
AppParam[1]:=' ';
|
||||
Move(ComLine[1],AppParam[2],length(Comline));
|
||||
AppParam[Length(ComLine)+2]:=#0;
|
||||
if not CreateProcess(PChar(@AppPath), PChar(@AppParam), Nil, Nil, False,$20, Nil, Nil, SI, PI) then
|
||||
begin
|
||||
DosError:=Last2DosError(GetLastError);
|
||||
exit;
|
||||
end
|
||||
else
|
||||
DosError:=0;
|
||||
Proc:=PI.hProcess;
|
||||
CloseHandle(PI.hThread);
|
||||
if WaitForSingleObject(Proc, Infinite) <> $ffffffff then
|
||||
GetExitCodeProcess(Proc,l)
|
||||
else
|
||||
l:=$ffffffff;
|
||||
CloseHandle(Proc);
|
||||
LastDosExitCode:=l;
|
||||
end;
|
||||
{$endif MSWindows}
|
||||
{$ifdef Linux}
|
||||
Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
|
||||
var
|
||||
pid,status : longint;
|
||||
Begin
|
||||
LastDosExitCode:=0;
|
||||
pid:=Fork;
|
||||
if pid=0 then
|
||||
begin
|
||||
{The child does the actual exec, and then exits}
|
||||
Execl(@Path[1],@ComLine[1]);
|
||||
{If the execve fails, we return an exitvalue of 127, to let it be known}
|
||||
__exit(127);
|
||||
end
|
||||
else
|
||||
if pid=-1 then {Fork failed}
|
||||
begin
|
||||
DosError:=8;
|
||||
exit
|
||||
end;
|
||||
{We're in the parent, let's wait.}
|
||||
WaitPid(Pid,@Status,0);
|
||||
LastDosExitCode:=Status; // WaitPid and result-convert
|
||||
if (LastDosExitCode>=0) and (LastDosExitCode<>127) then
|
||||
DosError:=0
|
||||
else
|
||||
DosError:=8; // perhaps one time give an better error
|
||||
End;
|
||||
{$endif Linux}
|
||||
|
||||
function dosexitcode : word;
|
||||
begin
|
||||
dosexitcode:=lastdosexitcode;
|
||||
end;
|
||||
|
||||
|
||||
procedure swapvectors;
|
||||
begin
|
||||
end;
|
||||
|
||||
|
||||
procedure getcbreak(var breakvalue : boolean);
|
||||
begin
|
||||
{ !! No Win32 Function !! }
|
||||
end;
|
||||
|
||||
|
||||
procedure setcbreak(breakvalue : boolean);
|
||||
begin
|
||||
{ !! No Win32 Function !! }
|
||||
end;
|
||||
|
||||
|
||||
procedure getverify(var verify : boolean);
|
||||
begin
|
||||
{ !! No Win32 Function !! }
|
||||
end;
|
||||
|
||||
|
||||
procedure setverify(verify : boolean);
|
||||
begin
|
||||
{ !! No Win32 Function !! }
|
||||
end;
|
||||
|
||||
|
||||
{******************************************************************************
|
||||
--- Disk ---
|
||||
******************************************************************************}
|
||||
|
||||
{$ifdef Linux]
|
||||
{
|
||||
The Diskfree and Disksize functions need a file on the specified drive, since this
|
||||
is required for the statfs system call.
|
||||
These filenames are set in drivestr[0..26], and have been preset to :
|
||||
0 - '.' (default drive - hence current dir is ok.)
|
||||
1 - '/fd0/.' (floppy drive 1 - should be adapted to local system )
|
||||
2 - '/fd1/.' (floppy drive 2 - should be adapted to local system )
|
||||
3 - '/' (C: equivalent of dos is the root partition)
|
||||
4..26 (can be set by you're own applications)
|
||||
! Use AddDisk() to Add new drives !
|
||||
They both return -1 when a failure occurs.
|
||||
}
|
||||
Const
|
||||
FixDriveStr : array[0..3] of pchar=(
|
||||
'.',
|
||||
'/fd0/.',
|
||||
'/fd1/.',
|
||||
'/.'
|
||||
);
|
||||
var
|
||||
Drives : byte = 4;
|
||||
var
|
||||
DriveStr : array[4..26] of pchar;
|
||||
|
||||
Procedure AddDisk(const path:string);
|
||||
begin
|
||||
if not (DriveStr[Drives]=nil) then
|
||||
FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
|
||||
GetMem(DriveStr[Drives],length(Path)+1);
|
||||
StrPCopy(DriveStr[Drives],path);
|
||||
inc(Drives);
|
||||
if Drives>26 then
|
||||
Drives:=4;
|
||||
end;
|
||||
|
||||
Function DiskFree(Drive: Byte): int64;
|
||||
var
|
||||
fs : tstatfs;
|
||||
Begin
|
||||
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (statfs(fixdrivestr[drive],fs)=0)) or
|
||||
((not (drivestr[Drive]=nil)) and (statfs(drivestr[drive],fs)=0)) then
|
||||
Diskfree:=int64(fs.f_bavail)*int64(fs.f_bsize)
|
||||
else
|
||||
Diskfree:=-1;
|
||||
End;
|
||||
|
||||
Function DiskSize(Drive: Byte): int64;
|
||||
var
|
||||
fs : tstatfs;
|
||||
Begin
|
||||
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (statfs(fixdrivestr[drive],fs)=0)) or
|
||||
((not (drivestr[Drive]=nil)) and (statfs(drivestr[drive],fs)=0)) then
|
||||
Disksize:=int64(fs.f_blocks)*int64(fs.f_bsize)
|
||||
else
|
||||
Disksize:=-1;
|
||||
End;
|
||||
|
||||
{$else linux}
|
||||
|
||||
function diskfree(drive : byte) : int64;
|
||||
begin
|
||||
DiskFree:=SysUtils.DiskFree(drive);
|
||||
end;
|
||||
|
||||
|
||||
function disksize(drive : byte) : int64;
|
||||
begin
|
||||
DiskSize:=SysUtils.DiskSize(drive);
|
||||
end;
|
||||
|
||||
{$endif linux}
|
||||
|
||||
{******************************************************************************
|
||||
--- Findfirst FindNext ---
|
||||
******************************************************************************}
|
||||
|
||||
procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
|
||||
begin
|
||||
DosError:=SysUtils.FindFirst(Path,Attr,f);
|
||||
end;
|
||||
|
||||
|
||||
procedure findnext(var f : searchRec);
|
||||
begin
|
||||
DosError:=Sysutils.FindNext(f);
|
||||
end;
|
||||
|
||||
|
||||
Procedure FindClose(Var f: SearchRec);
|
||||
begin
|
||||
Sysutils.FindClose(f);
|
||||
end;
|
||||
|
||||
|
||||
{******************************************************************************
|
||||
--- File ---
|
||||
******************************************************************************}
|
||||
|
||||
procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
|
||||
var
|
||||
p1,i : longint;
|
||||
begin
|
||||
{ allow slash as backslash }
|
||||
for i:=1 to length(path) do
|
||||
if path[i]='/' then path[i]:='\';
|
||||
{ get drive name }
|
||||
p1:=pos(':',path);
|
||||
if p1>0 then
|
||||
begin
|
||||
dir:=path[1]+':';
|
||||
delete(path,1,p1);
|
||||
end
|
||||
else
|
||||
dir:='';
|
||||
{ split the path and the name, there are no more path informtions }
|
||||
{ if path contains no backslashes }
|
||||
while true do
|
||||
begin
|
||||
p1:=pos('\',path);
|
||||
if p1=0 then
|
||||
break;
|
||||
dir:=dir+copy(path,1,p1);
|
||||
delete(path,1,p1);
|
||||
end;
|
||||
{ try to find out a extension }
|
||||
p1:=pos('.',path);
|
||||
if p1>0 then
|
||||
begin
|
||||
ext:=copy(path,p1,4);
|
||||
delete(path,p1,length(path)-p1+1);
|
||||
end
|
||||
else
|
||||
ext:='';
|
||||
name:=path;
|
||||
end;
|
||||
|
||||
|
||||
function fexpand(const path : pathstr) : pathstr;
|
||||
|
||||
var
|
||||
s,pa : string[79];
|
||||
i,j : longint;
|
||||
begin
|
||||
getdir(0,s);
|
||||
pa:=upper(path);
|
||||
{ allow slash as backslash }
|
||||
for i:=1 to length(pa) do
|
||||
if pa[i]='/' then
|
||||
pa[i]:='\';
|
||||
|
||||
if (length(pa)>1) and (pa[1] in ['A'..'Z']) and (pa[2]=':') then
|
||||
begin
|
||||
{ we must get the right directory }
|
||||
getdir(ord(pa[1])-ord('A')+1,s);
|
||||
if (ord(pa[0])>2) and (pa[3]<>'\') then
|
||||
if pa[1]=s[1] then
|
||||
pa:=s+'\'+copy (pa,3,length(pa))
|
||||
else
|
||||
pa:=pa[1]+':\'+copy (pa,3,length(pa))
|
||||
end
|
||||
else
|
||||
if pa[1]='\' then
|
||||
pa:=s[1]+':'+pa
|
||||
else if s[0]=#3 then
|
||||
pa:=s+pa
|
||||
else
|
||||
pa:=s+'\'+pa;
|
||||
|
||||
{ Turbo Pascal gives current dir on drive if only drive given as parameter! }
|
||||
if length(pa) = 2 then
|
||||
begin
|
||||
getdir(byte(pa[1])-64,s);
|
||||
pa := s;
|
||||
end;
|
||||
|
||||
{First remove all references to '\.\'}
|
||||
while pos ('\.\',pa)<>0 do
|
||||
delete (pa,pos('\.\',pa),2);
|
||||
{Now remove also all references to '\..\' + of course previous dirs..}
|
||||
repeat
|
||||
i:=pos('\..\',pa);
|
||||
if i<>0 then
|
||||
begin
|
||||
j:=i-1;
|
||||
while (j>1) and (pa[j]<>'\') do
|
||||
dec (j);
|
||||
if pa[j+1] = ':' then j := 3;
|
||||
delete (pa,j,i-j+3);
|
||||
end;
|
||||
until i=0;
|
||||
|
||||
{ Turbo Pascal gets rid of a \.. at the end of the path }
|
||||
{ Now remove also any reference to '\..' at end of line
|
||||
+ of course previous dir.. }
|
||||
i:=pos('\..',pa);
|
||||
if i<>0 then
|
||||
begin
|
||||
if i = length(pa) - 2 then
|
||||
begin
|
||||
j:=i-1;
|
||||
while (j>1) and (pa[j]<>'\') do
|
||||
dec (j);
|
||||
delete (pa,j,i-j+3);
|
||||
end;
|
||||
pa := pa + '\';
|
||||
end;
|
||||
{ Remove End . and \}
|
||||
if (length(pa)>0) and (pa[length(pa)]='.') then
|
||||
dec(byte(pa[0]));
|
||||
{ if only the drive + a '\' is left then the '\' should be left to prevtn the program
|
||||
accessing the current directory on the drive rather than the root!}
|
||||
{ if the last char of path = '\' then leave it in as this is what TP does! }
|
||||
if ((length(pa)>3) and (pa[length(pa)]='\')) and (path[length(path)] <> '\') then
|
||||
dec(byte(pa[0]));
|
||||
{ if only a drive is given in path then there should be a '\' at the
|
||||
end of the string given back }
|
||||
if length(path) = 2 then pa := pa + '\';
|
||||
fexpand:=pa;
|
||||
end;
|
||||
|
||||
Function FSearch(path: pathstr; dirlist: string): pathstr;
|
||||
var
|
||||
i,p1 : longint;
|
||||
s : searchrec;
|
||||
newdir : pathstr;
|
||||
begin
|
||||
{ No wildcards allowed in these things }
|
||||
if (pos('?',path)<>0) or (pos('*',path)<>0) then
|
||||
fsearch:=''
|
||||
else
|
||||
begin
|
||||
{ allow slash as backslash }
|
||||
for i:=1 to length(dirlist) do
|
||||
if dirlist[i]='/' then dirlist[i]:='\';
|
||||
repeat
|
||||
p1:=pos(';',dirlist);
|
||||
if p1=0 then
|
||||
begin
|
||||
newdir:=copy(dirlist,1,p1-1);
|
||||
delete(dirlist,1,p1);
|
||||
end
|
||||
else
|
||||
begin
|
||||
newdir:=dirlist;
|
||||
dirlist:='';
|
||||
end;
|
||||
if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
|
||||
newdir:=newdir+'\';
|
||||
findfirst(newdir+path,anyfile,s);
|
||||
if doserror=0 then
|
||||
newdir:=newdir+path
|
||||
else
|
||||
newdir:='';
|
||||
until (dirlist='') or (newdir<>'');
|
||||
fsearch:=newdir;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure getftime(var f;var tim : longint);
|
||||
begin
|
||||
tim:=FileGetDate(filerec(f).handle);
|
||||
end;
|
||||
|
||||
|
||||
procedure setftime(var f;time : longint);
|
||||
begin
|
||||
{$ifdef linux}
|
||||
FileSetDate(filerec(f).name,Time);
|
||||
{$else}
|
||||
FileSetDate(filerec(f).handle,Time);
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
|
||||
{$ifdef linux}
|
||||
procedure getfattr(var f;var attr : word);
|
||||
Var
|
||||
info : tstatbuf;
|
||||
LinAttr : longint;
|
||||
Begin
|
||||
DosError:=0;
|
||||
if (FStat(filerec(f).handle,info)<>0) then
|
||||
begin
|
||||
Attr:=0;
|
||||
DosError:=3;
|
||||
exit;
|
||||
end
|
||||
else
|
||||
LinAttr:=Info.st_Mode;
|
||||
if S_ISDIR(LinAttr) then
|
||||
Attr:=$10
|
||||
else
|
||||
Attr:=$20;
|
||||
if Access(@filerec(f).name,W_OK)<>0 then
|
||||
Attr:=Attr or $1;
|
||||
if (not S_ISDIR(LinAttr)) and (filerec(f).name[0]='.') then
|
||||
Attr:=Attr or $2;
|
||||
end;
|
||||
{$else}
|
||||
procedure getfattr(var f;var attr : word);
|
||||
var
|
||||
l : longint;
|
||||
begin
|
||||
l:=FileGetAttr(filerec(f).name);
|
||||
attr:=l;
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
|
||||
procedure setfattr(var f;attr : word);
|
||||
begin
|
||||
{$ifdef MSWindows}
|
||||
FileSetAttr(filerec(f).name,attr);
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
|
||||
{******************************************************************************
|
||||
--- Environment ---
|
||||
******************************************************************************}
|
||||
|
||||
{
|
||||
The environment is a block of zero terminated strings
|
||||
terminated by a #0
|
||||
}
|
||||
|
||||
{$ifdef MSWindows}
|
||||
function GetEnvironmentStrings : pchar;stdcall;
|
||||
external 'Kernel32.dll' name 'GetEnvironmentStringsA';
|
||||
function FreeEnvironmentStrings(p : pchar) : boolean;stdcall;
|
||||
external 'Kernel32.dll' name 'FreeEnvironmentStringsA';
|
||||
|
||||
function envcount : longint;
|
||||
var
|
||||
hp,p : pchar;
|
||||
count : longint;
|
||||
begin
|
||||
p:=GetEnvironmentStrings;
|
||||
hp:=p;
|
||||
count:=0;
|
||||
while hp^<>#0 do
|
||||
begin
|
||||
{ next string entry}
|
||||
hp:=hp+strlen(hp)+1;
|
||||
inc(count);
|
||||
end;
|
||||
FreeEnvironmentStrings(p);
|
||||
envcount:=count;
|
||||
end;
|
||||
|
||||
|
||||
Function EnvStr(index: integer): string;
|
||||
var
|
||||
hp,p : pchar;
|
||||
count,i : longint;
|
||||
begin
|
||||
{ envcount takes some time in win32 }
|
||||
count:=envcount;
|
||||
|
||||
{ range checking }
|
||||
if (index<=0) or (index>count) then
|
||||
begin
|
||||
envstr:='';
|
||||
exit;
|
||||
end;
|
||||
p:=GetEnvironmentStrings;
|
||||
hp:=p;
|
||||
|
||||
{ retrive the string with the given index }
|
||||
for i:=2 to index do
|
||||
hp:=hp+strlen(hp)+1;
|
||||
|
||||
envstr:=strpas(hp);
|
||||
FreeEnvironmentStrings(p);
|
||||
end;
|
||||
|
||||
|
||||
Function GetEnv(envvar: string): string;
|
||||
var
|
||||
s : string;
|
||||
i : longint;
|
||||
hp,p : pchar;
|
||||
begin
|
||||
getenv:='';
|
||||
p:=GetEnvironmentStrings;
|
||||
hp:=p;
|
||||
while hp^<>#0 do
|
||||
begin
|
||||
s:=strpas(hp);
|
||||
i:=pos('=',s);
|
||||
if copy(s,1,i-1)=envvar then
|
||||
begin
|
||||
getenv:=copy(s,i+1,length(s)-i);
|
||||
break;
|
||||
end;
|
||||
{ next string entry}
|
||||
hp:=hp+strlen(hp)+1;
|
||||
end;
|
||||
FreeEnvironmentStrings(p);
|
||||
end;
|
||||
{$else}
|
||||
|
||||
function envcount : longint;
|
||||
begin
|
||||
envcount:=0;
|
||||
end;
|
||||
|
||||
|
||||
Function EnvStr(index: integer): string;
|
||||
begin
|
||||
envstr:='';
|
||||
end;
|
||||
|
||||
|
||||
Function GetEnv(envvar: string): string;
|
||||
begin
|
||||
getenv:=GetEnvironmentVariable(envvar);
|
||||
end;
|
||||
|
||||
{$endif}
|
||||
|
||||
|
||||
{******************************************************************************
|
||||
--- 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;
|
||||
|
||||
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.12 2004-06-20 08:55:29 florian
|
||||
* logs truncated
|
||||
|
||||
}
|
||||
@ -55,9 +55,6 @@ interface
|
||||
implementation
|
||||
|
||||
uses
|
||||
{$ifdef delphi}
|
||||
sysutils,
|
||||
{$endif}
|
||||
cutils,globtype,systems,cclasses,
|
||||
verbose,finput,fmodule,script,cpuinfo,
|
||||
cgbase,
|
||||
@ -1358,7 +1355,7 @@ var
|
||||
procedure TPPCMPWAssembler.WriteExternals;
|
||||
begin
|
||||
currentasmlist:=self;
|
||||
objectlibrary.symbolsearch.foreach_static({$ifdef fpcprocvar}@{$endif}writeexternal,nil);
|
||||
objectlibrary.symbolsearch.foreach_static(@writeexternal,nil);
|
||||
end;
|
||||
|
||||
|
||||
@ -1487,7 +1484,11 @@ initialization
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.39 2004-10-09 10:48:34 olle
|
||||
Revision 1.40 2004-10-15 09:30:13 mazen
|
||||
- remove $IFDEF DELPHI and related code
|
||||
- remove $IFDEF FPCPROCVAR and related code
|
||||
|
||||
Revision 1.39 2004/10/09 10:48:34 olle
|
||||
* minor fix
|
||||
|
||||
Revision 1.38 2004/09/10 11:23:52 olle
|
||||
|
||||
@ -81,7 +81,7 @@ unit cpupi;
|
||||
else
|
||||
begin
|
||||
locals := 0;
|
||||
current_procinfo.procdef.localst.foreach_static({$ifdef FPCPROCVAR}@{$endif}count_locals,@locals);
|
||||
current_procinfo.procdef.localst.foreach_static(@count_locals,@locals);
|
||||
if locals <> 0 then
|
||||
{ at 0(r1), the previous value of r1 will be stored }
|
||||
tg.setfirsttemp(4);
|
||||
@ -145,7 +145,11 @@ begin
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.35 2004-06-20 08:55:32 florian
|
||||
Revision 1.36 2004-10-15 09:30:13 mazen
|
||||
- remove $IFDEF DELPHI and related code
|
||||
- remove $IFDEF FPCPROCVAR and related code
|
||||
|
||||
Revision 1.35 2004/06/20 08:55:32 florian
|
||||
* logs truncated
|
||||
|
||||
Revision 1.34 2004/02/19 17:07:42 florian
|
||||
|
||||
@ -43,11 +43,7 @@ implementation
|
||||
cutils,verbose,globals,
|
||||
symconst,symbase,symsym,symtable,defutil,paramgr,parabase,
|
||||
{$ifdef GDB}
|
||||
{$ifdef delphi}
|
||||
sysutils,
|
||||
{$else}
|
||||
strings,
|
||||
{$endif}
|
||||
gdb,
|
||||
{$endif GDB}
|
||||
cgbase,pass_2,
|
||||
@ -100,7 +96,11 @@ begin
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.29 2004-09-25 14:23:54 peter
|
||||
Revision 1.30 2004-10-15 09:30:13 mazen
|
||||
- remove $IFDEF DELPHI and related code
|
||||
- remove $IFDEF FPCPROCVAR and related code
|
||||
|
||||
Revision 1.29 2004/09/25 14:23:54 peter
|
||||
* ungetregister is now only used for cpuregisters, renamed to
|
||||
ungetcpuregister
|
||||
* renamed (get|unget)explicitregister(s) to ..cpuregister
|
||||
|
||||
Loading…
Reference in New Issue
Block a user