mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-31 10:11:27 +01:00
989 lines
25 KiB
ObjectPascal
989 lines
25 KiB
ObjectPascal
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2004 by Karoly Balogh for Genesi S.a.r.l.
|
|
|
|
Heavily based on the Commodore Amiga/m68k RTL by Nils Sjoholm and
|
|
Carl Eric Codere
|
|
|
|
MorphOS port was done on a free Pegasos II/G4 machine
|
|
provided by Genesi S.a.r.l. <www.genesi.lu>
|
|
|
|
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.
|
|
|
|
**********************************************************************}
|
|
{$INLINE ON}
|
|
|
|
unit Dos;
|
|
|
|
{--------------------------------------------------------------------}
|
|
{ LEFT TO DO: }
|
|
{--------------------------------------------------------------------}
|
|
{ o DiskFree / Disksize don't work as expected }
|
|
{ o Implement EnvCount,EnvStr }
|
|
{ o FindFirst should only work with correct attributes }
|
|
{--------------------------------------------------------------------}
|
|
|
|
|
|
interface
|
|
|
|
type
|
|
SearchRec = Packed Record
|
|
{ watch out this is correctly aligned for all processors }
|
|
{ don't modify. }
|
|
{ Replacement for Fill }
|
|
{0} AnchorPtr : Pointer; { Pointer to the Anchorpath structure }
|
|
{4} Fill: Array[1..15] of Byte; {future use}
|
|
{End of replacement for fill}
|
|
Attr : BYTE; {attribute of found file}
|
|
Time : LongInt; {last modify date of found file}
|
|
Size : LongInt; {file size of found file}
|
|
Name : String[255]; {name of found file}
|
|
End;
|
|
|
|
{$I dosh.inc}
|
|
|
|
implementation
|
|
|
|
{$DEFINE HAS_GETMSCOUNT}
|
|
{$DEFINE HAS_GETCBREAK}
|
|
{$DEFINE HAS_SETCBREAK}
|
|
|
|
{$DEFINE FPC_FEXPAND_VOLUMES} (* Full paths begin with drive specification *)
|
|
{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
|
|
{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
|
|
{$I dos.inc}
|
|
|
|
|
|
{ * include MorphOS specific functions & definitions * }
|
|
|
|
{$include execd.inc}
|
|
{$include execf.inc}
|
|
{$include timerd.inc}
|
|
{$include doslibd.inc}
|
|
{$include doslibf.inc}
|
|
{$include utilf.inc}
|
|
|
|
const
|
|
DaysPerMonth : Array[1..12] of ShortInt =
|
|
(031,028,031,030,031,030,031,031,030,031,030,031);
|
|
DaysPerYear : Array[1..12] of Integer =
|
|
(031,059,090,120,151,181,212,243,273,304,334,365);
|
|
DaysPerLeapYear : Array[1..12] of Integer =
|
|
(031,060,091,121,152,182,213,244,274,305,335,366);
|
|
SecsPerYear : LongInt = 31536000;
|
|
SecsPerLeapYear : LongInt = 31622400;
|
|
SecsPerDay : LongInt = 86400;
|
|
SecsPerHour : Integer = 3600;
|
|
SecsPerMinute : ShortInt = 60;
|
|
TICKSPERSECOND = 50;
|
|
|
|
|
|
{******************************************************************************
|
|
--- Internal routines ---
|
|
******************************************************************************}
|
|
|
|
{ * PathConv is implemented in the system unit! * }
|
|
function PathConv(path: string): string; external name 'PATHCONV';
|
|
|
|
function dosLock(const name: String;
|
|
accessmode: Longint) : LongInt;
|
|
var
|
|
buffer: array[0..255] of Char;
|
|
begin
|
|
move(name[1],buffer,length(name));
|
|
buffer[length(name)]:=#0;
|
|
dosLock:=Lock(buffer,accessmode);
|
|
end;
|
|
|
|
function BADDR(bval: LongInt): Pointer; Inline;
|
|
begin
|
|
BADDR:=Pointer(bval Shl 2);
|
|
end;
|
|
|
|
function BSTR2STRING(s : LongInt): PChar; Inline;
|
|
begin
|
|
BSTR2STRING:=Pointer(Longint(BADDR(s))+1);
|
|
end;
|
|
|
|
function IsLeapYear(Source : Word) : Boolean;
|
|
begin
|
|
if (source Mod 400 = 0) or ((source Mod 4 = 0) and (source Mod 100 <> 0)) then
|
|
IsLeapYear:=True
|
|
else
|
|
IsLeapYear:=False;
|
|
end;
|
|
|
|
procedure Amiga2DateStamp(Date : LongInt; var TotalDays,Minutes,Ticks: longint);
|
|
{ Converts a value in seconds past 1978 to a value in AMIGA DateStamp format }
|
|
{ Taken from SWAG and modified to work with the Amiga format - CEC }
|
|
var
|
|
LocalDate : LongInt;
|
|
Done : Boolean;
|
|
TotDays : Integer;
|
|
Y: Word;
|
|
H: Word;
|
|
Min: Word;
|
|
S : Word;
|
|
begin
|
|
Y := 1978; H := 0; Min := 0; S := 0;
|
|
TotalDays := 0;
|
|
Minutes := 0;
|
|
Ticks := 0;
|
|
LocalDate := Date;
|
|
Done := false;
|
|
while not Done do
|
|
begin
|
|
if LocalDate >= SecsPerYear then
|
|
begin
|
|
Inc(Y,1);
|
|
Dec(LocalDate,SecsPerYear);
|
|
Inc(TotalDays,DaysPerYear[12]);
|
|
end else
|
|
Done := true;
|
|
if (IsLeapYear(Y+1)) and (LocalDate >= SecsPerLeapYear) and
|
|
(Not Done) then
|
|
begin
|
|
Inc(Y,1);
|
|
Dec(LocalDate,SecsPerLeapYear);
|
|
Inc(TotalDays,DaysPerLeapYear[12]);
|
|
end;
|
|
end; { END WHILE }
|
|
|
|
TotDays := LocalDate Div SecsPerDay;
|
|
{ Total number of days }
|
|
TotalDays := TotalDays + TotDays;
|
|
Dec(LocalDate,TotDays*SecsPerDay);
|
|
{ Absolute hours since start of day }
|
|
H := LocalDate Div SecsPerHour;
|
|
{ Convert to minutes }
|
|
Minutes := H*60;
|
|
Dec(LocalDate,(H * SecsPerHour));
|
|
{ Find the remaining minutes to add }
|
|
Min := LocalDate Div SecsPerMinute;
|
|
Dec(LocalDate,(Min * SecsPerMinute));
|
|
Minutes:=Minutes+Min;
|
|
{ Find the number of seconds and convert to ticks }
|
|
S := LocalDate;
|
|
Ticks:=TICKSPERSECOND*S;
|
|
end;
|
|
|
|
|
|
function dosSetProtection(const name: string; mask:longint): Boolean;
|
|
var
|
|
buffer : array[0..255] of Char;
|
|
begin
|
|
move(name[1],buffer,length(name));
|
|
buffer[length(name)]:=#0;
|
|
dosSetProtection:=SetProtection(buffer,mask);
|
|
end;
|
|
|
|
function dosSetFileDate(name: string; p : PDateStamp): Boolean;
|
|
var
|
|
buffer : array[0..255] of Char;
|
|
begin
|
|
move(name[1],buffer,length(name));
|
|
buffer[length(name)]:=#0;
|
|
dosSetFileDate:=SetFileDate(buffer,p);
|
|
end;
|
|
|
|
|
|
{******************************************************************************
|
|
--- Info / Date / Time ---
|
|
******************************************************************************}
|
|
|
|
function DosVersion: Word;
|
|
var p: PLibrary;
|
|
begin
|
|
p:=PLibrary(AOS_DOSBase);
|
|
DosVersion:= p^.lib_Version or (p^.lib_Revision shl 8);
|
|
end;
|
|
|
|
{ Here are a lot of stuff just for setdate and settime }
|
|
|
|
var
|
|
TimerBase : Pointer;
|
|
|
|
|
|
procedure NewList (list: pList);
|
|
begin
|
|
with list^ do begin
|
|
lh_Head := pNode(@lh_Tail);
|
|
lh_Tail := NIL;
|
|
lh_TailPred := pNode(@lh_Head)
|
|
end;
|
|
end;
|
|
|
|
function CreateExtIO (port: pMsgPort; size: Longint): pIORequest;
|
|
var
|
|
IOReq: pIORequest;
|
|
begin
|
|
IOReq := NIL;
|
|
if port <> NIL then
|
|
begin
|
|
IOReq := execAllocMem(size, MEMF_CLEAR);
|
|
if IOReq <> NIL then
|
|
begin
|
|
IOReq^.io_Message.mn_Node.ln_Type := 7;
|
|
IOReq^.io_Message.mn_Length := size;
|
|
IOReq^.io_Message.mn_ReplyPort := port;
|
|
end;
|
|
end;
|
|
CreateExtIO := IOReq;
|
|
end;
|
|
|
|
procedure DeleteExtIO (ioReq: pIORequest);
|
|
begin
|
|
if ioReq <> NIL then
|
|
begin
|
|
ioReq^.io_Message.mn_Node.ln_Type := $FF;
|
|
ioReq^.io_Message.mn_ReplyPort := pMsgPort(-1);
|
|
ioReq^.io_Device := pDevice(-1);
|
|
execFreeMem(ioReq, ioReq^.io_Message.mn_Length);
|
|
end
|
|
end;
|
|
|
|
function Createport(name : PChar; pri : longint): pMsgPort;
|
|
var
|
|
sigbit : ShortInt;
|
|
port : pMsgPort;
|
|
begin
|
|
sigbit := AllocSignal(-1);
|
|
if sigbit = -1 then CreatePort := nil;
|
|
port := execAllocMem(sizeof(tMsgPort),MEMF_CLEAR);
|
|
if port = nil then begin
|
|
FreeSignal(sigbit);
|
|
CreatePort := nil;
|
|
end;
|
|
with port^ do begin
|
|
if assigned(name) then
|
|
mp_Node.ln_Name := name
|
|
else mp_Node.ln_Name := nil;
|
|
mp_Node.ln_Pri := pri;
|
|
mp_Node.ln_Type := 4;
|
|
mp_Flags := 0;
|
|
mp_SigBit := sigbit;
|
|
mp_SigTask := FindTask(nil);
|
|
end;
|
|
if assigned(name) then AddPort(port)
|
|
else NewList(addr(port^.mp_MsgList));
|
|
CreatePort := port;
|
|
end;
|
|
|
|
procedure DeletePort (port: pMsgPort);
|
|
begin
|
|
if port <> NIL then
|
|
begin
|
|
if port^.mp_Node.ln_Name <> NIL then
|
|
RemPort(port);
|
|
|
|
port^.mp_Node.ln_Type := $FF;
|
|
port^.mp_MsgList.lh_Head := pNode(-1);
|
|
FreeSignal(port^.mp_SigBit);
|
|
execFreeMem(port, sizeof(tMsgPort));
|
|
end;
|
|
end;
|
|
|
|
|
|
function Create_Timer(theUnit : longint) : pTimeRequest;
|
|
var
|
|
Error : longint;
|
|
TimerPort : pMsgPort;
|
|
TimeReq : pTimeRequest;
|
|
begin
|
|
TimerPort := CreatePort(Nil, 0);
|
|
if TimerPort = Nil then
|
|
Create_Timer := Nil;
|
|
TimeReq := pTimeRequest(CreateExtIO(TimerPort,sizeof(tTimeRequest)));
|
|
if TimeReq = Nil then begin
|
|
DeletePort(TimerPort);
|
|
Create_Timer := Nil;
|
|
end;
|
|
Error := OpenDevice(TIMERNAME, theUnit, pIORequest(TimeReq), 0);
|
|
if Error <> 0 then begin
|
|
DeleteExtIO(pIORequest(TimeReq));
|
|
DeletePort(TimerPort);
|
|
Create_Timer := Nil;
|
|
end;
|
|
TimerBase := pointer(TimeReq^.tr_Node.io_Device);
|
|
Create_Timer := pTimeRequest(TimeReq);
|
|
end;
|
|
|
|
Procedure Delete_Timer(WhichTimer : pTimeRequest);
|
|
var
|
|
WhichPort : pMsgPort;
|
|
begin
|
|
|
|
WhichPort := WhichTimer^.tr_Node.io_Message.mn_ReplyPort;
|
|
if assigned(WhichTimer) then begin
|
|
CloseDevice(pIORequest(WhichTimer));
|
|
DeleteExtIO(pIORequest(WhichTimer));
|
|
end;
|
|
if assigned(WhichPort) then
|
|
DeletePort(WhichPort);
|
|
end;
|
|
|
|
function set_new_time(secs, micro : longint): longint;
|
|
var
|
|
tr : ptimerequest;
|
|
begin
|
|
tr := create_timer(UNIT_MICROHZ);
|
|
|
|
{ non zero return says error }
|
|
if tr = nil then set_new_time := -1;
|
|
|
|
tr^.tr_time.tv_secs := secs;
|
|
tr^.tr_time.tv_micro := micro;
|
|
tr^.tr_node.io_Command := TR_SETSYSTIME;
|
|
DoIO(pIORequest(tr));
|
|
|
|
delete_timer(tr);
|
|
set_new_time := 0;
|
|
end;
|
|
|
|
function get_sys_time(tv : ptimeval): longint;
|
|
var
|
|
tr : ptimerequest;
|
|
begin
|
|
tr := create_timer( UNIT_MICROHZ );
|
|
|
|
{ non zero return says error }
|
|
if tr = nil then get_sys_time := -1;
|
|
|
|
tr^.tr_node.io_Command := TR_GETSYSTIME;
|
|
DoIO(pIORequest(tr));
|
|
|
|
{ structure assignment }
|
|
tv^ := tr^.tr_time;
|
|
|
|
delete_timer(tr);
|
|
get_sys_time := 0;
|
|
end;
|
|
|
|
procedure GetDate(Var Year, Month, MDay, WDay: Word);
|
|
var
|
|
cd : pClockData;
|
|
oldtime : ttimeval;
|
|
begin
|
|
new(cd);
|
|
get_sys_time(@oldtime);
|
|
Amiga2Date(oldtime.tv_secs,cd);
|
|
Year := cd^.year;
|
|
Month := cd^.month;
|
|
MDay := cd^.mday;
|
|
WDay := cd^.wday;
|
|
dispose(cd);
|
|
end;
|
|
|
|
procedure SetDate(Year, Month, Day: Word);
|
|
var
|
|
cd : pClockData;
|
|
oldtime : ttimeval;
|
|
begin
|
|
new(cd);
|
|
get_sys_time(@oldtime);
|
|
Amiga2Date(oldtime.tv_secs,cd);
|
|
cd^.year := Year;
|
|
cd^.month := Month;
|
|
cd^.mday := Day;
|
|
set_new_time(Date2Amiga(cd),0);
|
|
dispose(cd);
|
|
end;
|
|
|
|
procedure GetTime(Var Hour, Minute, Second, Sec100: Word);
|
|
var
|
|
cd : pClockData;
|
|
oldtime : ttimeval;
|
|
begin
|
|
new(cd);
|
|
get_sys_time(@oldtime);
|
|
Amiga2Date(oldtime.tv_secs,cd);
|
|
Hour := cd^.hour;
|
|
Minute := cd^.min;
|
|
Second := cd^.sec;
|
|
Sec100 := oldtime.tv_micro div 10000;
|
|
dispose(cd);
|
|
end;
|
|
|
|
|
|
Procedure SetTime(Hour, Minute, Second, Sec100: Word);
|
|
var
|
|
cd : pClockData;
|
|
oldtime : ttimeval;
|
|
begin
|
|
new(cd);
|
|
get_sys_time(@oldtime);
|
|
Amiga2Date(oldtime.tv_secs,cd);
|
|
cd^.hour := Hour;
|
|
cd^.min := Minute;
|
|
cd^.sec := Second;
|
|
set_new_time(Date2Amiga(cd), Sec100 * 10000);
|
|
dispose(cd);
|
|
end;
|
|
|
|
|
|
function GetMsCount: int64;
|
|
var
|
|
TV: TTimeVal;
|
|
begin
|
|
Get_Sys_Time (@TV);
|
|
GetMsCount := TV.TV_Secs * 1000 + TV.TV_Micro div 1000;
|
|
end;
|
|
|
|
{******************************************************************************
|
|
--- Exec ---
|
|
******************************************************************************}
|
|
|
|
|
|
procedure Exec(const Path: PathStr; const ComLine: ComStr);
|
|
var
|
|
tmpPath: array[0..255] of char;
|
|
result : longint;
|
|
tmpLock: longint;
|
|
begin
|
|
DosError:= 0;
|
|
LastDosExitCode:=0;
|
|
tmpPath:=PathConv(Path)+#0+ComLine+#0; // hacky... :)
|
|
|
|
{ Here we must first check if the command we wish to execute }
|
|
{ actually exists, because this is NOT handled by the }
|
|
{ _SystemTagList call (program will abort!!) }
|
|
|
|
{ Try to open with shared lock }
|
|
tmpLock:=Lock(tmpPath,SHARED_LOCK);
|
|
if tmpLock<>0 then
|
|
begin
|
|
{ File exists - therefore unlock it }
|
|
Unlock(tmpLock);
|
|
tmpPath[length(Path)]:=' '; // hacky... replaces first #0 from above, to get the whole string. :)
|
|
result:=SystemTagList(tmpPath,nil);
|
|
{ on return of -1 the shell could not be executed }
|
|
{ probably because there was not enough memory }
|
|
if result = -1 then
|
|
DosError:=8
|
|
else
|
|
LastDosExitCode:=word(result);
|
|
end
|
|
else
|
|
DosError:=3;
|
|
end;
|
|
|
|
|
|
procedure GetCBreak(Var BreakValue: Boolean);
|
|
begin
|
|
breakvalue := system.BreakOn;
|
|
end;
|
|
|
|
procedure SetCBreak(BreakValue: Boolean);
|
|
begin
|
|
system.Breakon := BreakValue;
|
|
end;
|
|
|
|
|
|
{******************************************************************************
|
|
--- Disk ---
|
|
******************************************************************************}
|
|
|
|
{ How to solve the problem with this: }
|
|
{ We could walk through the device list }
|
|
{ at startup to determine possible devices }
|
|
|
|
const
|
|
|
|
not_to_use_devs : array[0..12] of string =(
|
|
'DF0:',
|
|
'DF1:',
|
|
'DF2:',
|
|
'DF3:',
|
|
'PED:',
|
|
'PRJ:',
|
|
'PIPE:',
|
|
'RAM:',
|
|
'CON:',
|
|
'RAW:',
|
|
'SER:',
|
|
'PAR:',
|
|
'PRT:');
|
|
|
|
var
|
|
deviceids : array[1..20] of byte;
|
|
devicenames : array[1..20] of string[20];
|
|
numberofdevices : Byte;
|
|
|
|
Function DiskFree(Drive: Byte): int64;
|
|
Var
|
|
MyLock : LongInt;
|
|
Inf : pInfoData;
|
|
Free : Longint;
|
|
myproc : pProcess;
|
|
OldWinPtr : Pointer;
|
|
Begin
|
|
Free := -1;
|
|
{ Here we stop systemrequesters to appear }
|
|
myproc := pProcess(FindTask(nil));
|
|
OldWinPtr := myproc^.pr_WindowPtr;
|
|
myproc^.pr_WindowPtr := Pointer(-1);
|
|
{ End of systemrequesterstop }
|
|
New(Inf);
|
|
MyLock := dosLock(devicenames[deviceids[Drive]],SHARED_LOCK);
|
|
If MyLock <> 0 then begin
|
|
if Info(MyLock,Inf) then begin
|
|
Free := (Inf^.id_NumBlocks * Inf^.id_BytesPerBlock) -
|
|
(Inf^.id_NumBlocksUsed * Inf^.id_BytesPerBlock);
|
|
end;
|
|
Unlock(MyLock);
|
|
end;
|
|
Dispose(Inf);
|
|
{ Restore systemrequesters }
|
|
myproc^.pr_WindowPtr := OldWinPtr;
|
|
diskfree := Free;
|
|
end;
|
|
|
|
|
|
|
|
Function DiskSize(Drive: Byte): int64;
|
|
Var
|
|
MyLock : LongInt;
|
|
Inf : pInfoData;
|
|
Size : Longint;
|
|
myproc : pProcess;
|
|
OldWinPtr : Pointer;
|
|
Begin
|
|
Size := -1;
|
|
{ Here we stop systemrequesters to appear }
|
|
myproc := pProcess(FindTask(nil));
|
|
OldWinPtr := myproc^.pr_WindowPtr;
|
|
myproc^.pr_WindowPtr := Pointer(-1);
|
|
{ End of systemrequesterstop }
|
|
New(Inf);
|
|
MyLock := dosLock(devicenames[deviceids[Drive]],SHARED_LOCK);
|
|
If MyLock <> 0 then begin
|
|
if Info(MyLock,Inf) then begin
|
|
Size := (Inf^.id_NumBlocks * Inf^.id_BytesPerBlock);
|
|
end;
|
|
Unlock(MyLock);
|
|
end;
|
|
Dispose(Inf);
|
|
{ Restore systemrequesters }
|
|
myproc^.pr_WindowPtr := OldWinPtr;
|
|
disksize := Size;
|
|
end;
|
|
|
|
|
|
procedure FindFirst(const Path: PathStr; Attr: Word; Var f: SearchRec);
|
|
var
|
|
tmpStr: array[0..255] of Char;
|
|
Anchor: PAnchorPath;
|
|
Result: LongInt;
|
|
begin
|
|
tmpStr:=PathConv(path)+#0;
|
|
DosError:=0;
|
|
|
|
new(Anchor);
|
|
FillChar(Anchor^,sizeof(TAnchorPath),#0);
|
|
|
|
Result:=MatchFirst(@tmpStr,Anchor);
|
|
f.AnchorPtr:=Anchor;
|
|
if Result = ERROR_NO_MORE_ENTRIES then
|
|
DosError:=18
|
|
else
|
|
if Result<>0 then DosError:=3;
|
|
|
|
if DosError=0 then begin
|
|
{-------------------------------------------------------------------}
|
|
{ Here we fill up the SearchRec attribute, but we also do check }
|
|
{ something else, if the it does not match the mask we are looking }
|
|
{ for we should go to the next file or directory. }
|
|
{-------------------------------------------------------------------}
|
|
with Anchor^.ap_Info do begin
|
|
f.Time := fib_Date.ds_Days * (24 * 60 * 60) +
|
|
fib_Date.ds_Minute * 60 +
|
|
fib_Date.ds_Tick div 50;
|
|
f.attr := 0;
|
|
{*------------------------------------*}
|
|
{* Determine if is a file or a folder *}
|
|
{*------------------------------------*}
|
|
if fib_DirEntryType>0 then f.attr:=f.attr OR DIRECTORY;
|
|
|
|
{*------------------------------------*}
|
|
{* Determine if Read only *}
|
|
{* Readonly if R flag on and W flag *}
|
|
{* off. *}
|
|
{* Should we check also that EXEC *}
|
|
{* is zero? for read only? *}
|
|
{*------------------------------------*}
|
|
if ((fib_Protection and FIBF_READ) <> 0) and
|
|
((fib_Protection and FIBF_WRITE) = 0) then f.attr:=f.attr or READONLY;
|
|
f.Name := strpas(fib_FileName);
|
|
f.Size := fib_Size;
|
|
end; { end with }
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure FindNext(Var f: SearchRec);
|
|
var
|
|
Result: longint;
|
|
Anchor: PAnchorPath;
|
|
begin
|
|
DosError:=0;
|
|
Result:=MatchNext(f.AnchorPtr);
|
|
if Result = ERROR_NO_MORE_ENTRIES then
|
|
DosError:=18
|
|
else
|
|
if Result <> 0 then DosError:=3;
|
|
|
|
if DosError=0 then begin
|
|
{ Fill up the Searchrec information }
|
|
{ and also check if the files are with }
|
|
{ the correct attributes }
|
|
Anchor:=pAnchorPath(f.AnchorPtr);
|
|
with Anchor^.ap_Info do begin
|
|
f.Time := fib_Date.ds_Days * (24 * 60 * 60) +
|
|
fib_Date.ds_Minute * 60 +
|
|
fib_Date.ds_Tick div 50;
|
|
f.attr := 0;
|
|
{*------------------------------------*}
|
|
{* Determine if is a file or a folder *}
|
|
{*------------------------------------*}
|
|
if fib_DirEntryType > 0 then f.attr:=f.attr OR DIRECTORY;
|
|
|
|
{*------------------------------------*}
|
|
{* Determine if Read only *}
|
|
{* Readonly if R flag on and W flag *}
|
|
{* off. *}
|
|
{* Should we check also that EXEC *}
|
|
{* is zero? for read only? *}
|
|
{*------------------------------------*}
|
|
if ((fib_Protection and FIBF_READ) <> 0) and
|
|
((fib_Protection and FIBF_WRITE) = 0) then f.attr:=f.attr or READONLY;
|
|
f.Name := strpas(fib_FileName);
|
|
f.Size := fib_Size;
|
|
end; { end with }
|
|
end;
|
|
end;
|
|
|
|
procedure FindClose(Var f: SearchRec);
|
|
begin
|
|
MatchEnd(f.AnchorPtr);
|
|
if assigned(f.AnchorPtr) then
|
|
Dispose(PAnchorPath(f.AnchorPtr));
|
|
end;
|
|
|
|
|
|
{******************************************************************************
|
|
--- File ---
|
|
******************************************************************************}
|
|
|
|
function FSearch(path: PathStr; dirlist: String) : PathStr;
|
|
var
|
|
p1 : LongInt;
|
|
tmpSR : SearchRec;
|
|
newdir : PathStr;
|
|
begin
|
|
{ No wildcards allowed in these things }
|
|
if (pos('?',path)<>0) or (pos('*',path)<>0) or (path='') then
|
|
FSearch:=''
|
|
else begin
|
|
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,tmpSR);
|
|
if doserror=0 then
|
|
newdir:=newdir+path
|
|
else
|
|
newdir:='';
|
|
until (dirlist='') or (newdir<>'');
|
|
FSearch:=newdir;
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure getftime (var f; var time : longint);
|
|
{
|
|
This function returns a file's date and time as the number of
|
|
seconds after January 1, 1978 that the file was created.
|
|
}
|
|
var
|
|
FInfo : pFileInfoBlock;
|
|
FTime : Longint;
|
|
FLock : Longint;
|
|
Str : String;
|
|
i : integer;
|
|
begin
|
|
DosError:=0;
|
|
FTime := 0;
|
|
Str := StrPas(filerec(f).name);
|
|
for i:=1 to length(Str) do
|
|
if str[i]='\' then str[i]:='/';
|
|
FLock := dosLock(Str, SHARED_LOCK);
|
|
IF FLock <> 0 then begin
|
|
New(FInfo);
|
|
if Examine(FLock, FInfo) then begin
|
|
with FInfo^.fib_Date do
|
|
FTime := ds_Days * (24 * 60 * 60) +
|
|
ds_Minute * 60 +
|
|
ds_Tick div 50;
|
|
end else begin
|
|
FTime := 0;
|
|
end;
|
|
Unlock(FLock);
|
|
Dispose(FInfo);
|
|
end
|
|
else
|
|
DosError:=6;
|
|
time := FTime;
|
|
end;
|
|
|
|
|
|
Procedure setftime(var f; time : longint);
|
|
var
|
|
DateStamp: pDateStamp;
|
|
Str: String;
|
|
i: Integer;
|
|
Days, Minutes,Ticks: longint;
|
|
FLock: longint;
|
|
Begin
|
|
new(DateStamp);
|
|
Str := StrPas(filerec(f).name);
|
|
for i:=1 to length(Str) do
|
|
if str[i]='\' then str[i]:='/';
|
|
{ Check first of all, if file exists }
|
|
FLock := dosLock(Str, SHARED_LOCK);
|
|
IF FLock <> 0 then
|
|
begin
|
|
Unlock(FLock);
|
|
Amiga2DateStamp(time,Days,Minutes,ticks);
|
|
DateStamp^.ds_Days:=Days;
|
|
DateStamp^.ds_Minute:=Minutes;
|
|
DateStamp^.ds_Tick:=Ticks;
|
|
if dosSetFileDate(Str,DateStamp) then
|
|
DosError:=0
|
|
else
|
|
DosError:=6;
|
|
end
|
|
else
|
|
DosError:=2;
|
|
if assigned(DateStamp) then Dispose(DateStamp);
|
|
End;
|
|
|
|
procedure getfattr(var f; var attr : word);
|
|
var
|
|
info : pFileInfoBlock;
|
|
MyLock : Longint;
|
|
flags: word;
|
|
Str: String;
|
|
i: integer;
|
|
begin
|
|
DosError:=0;
|
|
flags:=0;
|
|
New(info);
|
|
Str := StrPas(filerec(f).name);
|
|
for i:=1 to length(Str) do
|
|
if str[i]='\' then str[i]:='/';
|
|
{ open with shared lock to check if file exists }
|
|
MyLock:=dosLock(Str,SHARED_LOCK);
|
|
if MyLock <> 0 then
|
|
Begin
|
|
Examine(MyLock,info);
|
|
{*------------------------------------*}
|
|
{* Determine if is a file or a folder *}
|
|
{*------------------------------------*}
|
|
if info^.fib_DirEntryType > 0 then
|
|
flags:=flags OR DIRECTORY;
|
|
|
|
{*------------------------------------*}
|
|
{* Determine if Read only *}
|
|
{* Readonly if R flag on and W flag *}
|
|
{* off. *}
|
|
{* Should we check also that EXEC *}
|
|
{* is zero? for read only? *}
|
|
{*------------------------------------*}
|
|
if ((info^.fib_Protection and FIBF_READ) <> 0)
|
|
AND ((info^.fib_Protection and FIBF_WRITE) = 0)
|
|
then
|
|
flags:=flags OR ReadOnly;
|
|
Unlock(mylock);
|
|
end
|
|
else
|
|
DosError:=3;
|
|
attr:=flags;
|
|
Dispose(info);
|
|
End;
|
|
|
|
|
|
procedure setfattr(var f; attr : word);
|
|
var
|
|
flags: longint;
|
|
tmpLock : longint;
|
|
begin
|
|
DosError:=0;
|
|
flags:=FIBF_WRITE;
|
|
|
|
{ By default files are read-write }
|
|
if attr and ReadOnly <> 0 then flags:=FIBF_READ; { Clear the Fibf_write flags }
|
|
|
|
{ no need for path conversion here, because file opening already }
|
|
{ converts the path (KB) }
|
|
|
|
{ create a shared lock on the file }
|
|
tmpLock:=Lock(filerec(f).name,SHARED_LOCK);
|
|
if tmpLock <> 0 then begin
|
|
Unlock(tmpLock);
|
|
if not SetProtection(filerec(f).name,flags) then DosError:=5;
|
|
end else
|
|
DosError:=3;
|
|
end;
|
|
|
|
|
|
|
|
{******************************************************************************
|
|
--- Environment ---
|
|
******************************************************************************}
|
|
|
|
var
|
|
strofpaths : string;
|
|
|
|
function getpathstring: string;
|
|
var
|
|
f : text;
|
|
s : string;
|
|
found : boolean;
|
|
temp : string[255];
|
|
begin
|
|
found := true;
|
|
temp := '';
|
|
assign(f,'ram:makepathstr');
|
|
rewrite(f);
|
|
writeln(f,'path >ram:temp.lst');
|
|
close(f);
|
|
exec('c:protect','ram:makepathstr sarwed quiet');
|
|
exec('ram:makepathstr','');
|
|
exec('c:delete','ram:makepathstr quiet');
|
|
assign(f,'ram:temp.lst');
|
|
reset(f);
|
|
{ skip the first line, garbage }
|
|
if not eof(f) then readln(f,s);
|
|
while not eof(f) do begin
|
|
readln(f,s);
|
|
if found then begin
|
|
temp := s;
|
|
found := false;
|
|
end else begin;
|
|
if (length(s) + length(temp)) < 255 then
|
|
temp := temp + ';' + s;
|
|
end;
|
|
end;
|
|
close(f);
|
|
exec('C:delete','ram:temp.lst quiet');
|
|
getpathstring := temp;
|
|
end;
|
|
|
|
|
|
function EnvCount: Longint;
|
|
{ HOW TO GET THIS VALUE: }
|
|
{ Each time this function is called, we look at the }
|
|
{ local variables in the Process structure (2.0+) }
|
|
{ And we also read all files in the ENV: directory }
|
|
begin
|
|
EnvCount := 0;
|
|
end;
|
|
|
|
|
|
function EnvStr(Index: LongInt): String;
|
|
begin
|
|
EnvStr:='';
|
|
end;
|
|
|
|
|
|
|
|
function GetEnv(envvar : String): String;
|
|
var
|
|
bufarr : array[0..255] of char;
|
|
strbuffer : array[0..255] of char;
|
|
temp : Longint;
|
|
begin
|
|
if UpCase(envvar) = 'PATH' then begin
|
|
if StrOfpaths = '' then StrOfPaths := GetPathString;
|
|
GetEnv := StrofPaths;
|
|
end else begin
|
|
move(envvar[1],strbuffer,length(envvar));
|
|
strbuffer[length(envvar)] := #0;
|
|
temp := GetVar(strbuffer,bufarr,255,$100);
|
|
if temp = -1 then
|
|
GetEnv := ''
|
|
else GetEnv := StrPas(bufarr);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure AddDevice(str : String);
|
|
begin
|
|
inc(numberofdevices);
|
|
deviceids[numberofdevices] := numberofdevices;
|
|
devicenames[numberofdevices] := str;
|
|
end;
|
|
|
|
function MakeDeviceName(str : pchar): string;
|
|
var
|
|
temp : string[20];
|
|
begin
|
|
temp := strpas(str);
|
|
temp := temp + ':';
|
|
MakeDeviceName := temp;
|
|
end;
|
|
|
|
function IsInDeviceList(str : string): boolean;
|
|
var
|
|
i : byte;
|
|
theresult : boolean;
|
|
begin
|
|
theresult := false;
|
|
for i := low(not_to_use_devs) to high(not_to_use_devs) do
|
|
begin
|
|
if str = not_to_use_devs[i] then begin
|
|
theresult := true;
|
|
break;
|
|
end;
|
|
end;
|
|
IsInDeviceList := theresult;
|
|
end;
|
|
|
|
procedure ReadInDevices;
|
|
var
|
|
dl : pDosList;
|
|
temp : pchar;
|
|
str : string[20];
|
|
begin
|
|
dl := LockDosList(LDF_DEVICES or LDF_READ );
|
|
repeat
|
|
dl := NextDosEntry(dl,LDF_DEVICES );
|
|
if dl <> nil then begin
|
|
temp := BSTR2STRING(dl^.dol_Name);
|
|
str := MakeDeviceName(temp);
|
|
if not IsInDeviceList(str) then
|
|
AddDevice(str);
|
|
end;
|
|
until dl = nil;
|
|
UnLockDosList(LDF_DEVICES or LDF_READ );
|
|
end;
|
|
|
|
begin
|
|
DosError:=0;
|
|
numberofdevices := 0;
|
|
StrOfPaths := '';
|
|
ReadInDevices;
|
|
end.
|