mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-16 15:59:30 +02:00
972 lines
24 KiB
ObjectPascal
972 lines
24 KiB
ObjectPascal
{
|
||
$Id$
|
||
This file is part of the Free Pascal run time library.
|
||
Copyright (c) 2004 by Karoly Balogh for Genesi S.a.r.l.
|
||
|
||
System unit for MorphOS/PowerPC
|
||
|
||
Uses parts of the Commodore Amiga/68k port by Carl Eric Codere
|
||
and Nils Sjoholm
|
||
|
||
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.
|
||
|
||
**********************************************************************}
|
||
|
||
unit {$ifdef VER1_0}SysMorph{$else}System{$endif};
|
||
|
||
interface
|
||
|
||
{$define FPC_IS_SYSTEM}
|
||
|
||
{$I systemh.inc}
|
||
|
||
type
|
||
THandle = LongInt;
|
||
|
||
{$I heaph.inc}
|
||
|
||
const
|
||
LineEnding = #10;
|
||
LFNSupport = True;
|
||
DirectorySeparator = '/';
|
||
DriveSeparator = ':';
|
||
PathSeparator = ';';
|
||
|
||
const
|
||
UnusedHandle : LongInt = -1;
|
||
StdInputHandle : LongInt = 0;
|
||
StdOutputHandle : LongInt = 0;
|
||
StdErrorHandle : LongInt = 0;
|
||
|
||
FileNameCaseSensitive : Boolean = False;
|
||
|
||
sLineBreak : string[1] = LineEnding;
|
||
DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF;
|
||
|
||
BreakOn : Boolean = True;
|
||
|
||
|
||
var
|
||
MOS_ExecBase : Pointer; external name '_ExecBase';
|
||
MOS_DOSBase : Pointer;
|
||
MOS_UtilityBase: Pointer;
|
||
|
||
MOS_heapPool : Pointer; { pointer for the OS pool for growing the heap }
|
||
MOS_origDir : LongInt; { original directory on startup }
|
||
MOS_ambMsg : Pointer;
|
||
MOS_ConName : PChar ='CON:10/30/620/100/FPC Console Output/AUTO/CLOSE/WAIT';
|
||
MOS_ConHandle: LongInt;
|
||
|
||
argc: LongInt;
|
||
argv: PPChar;
|
||
envp: PPChar;
|
||
|
||
|
||
implementation
|
||
|
||
{$I system.inc}
|
||
|
||
|
||
{*****************************************************************************
|
||
MorphOS structures
|
||
*****************************************************************************}
|
||
|
||
{$include execd.inc}
|
||
{$include timerd.inc}
|
||
{$include doslibd.inc}
|
||
|
||
|
||
{*****************************************************************************
|
||
MorphOS functions
|
||
*****************************************************************************}
|
||
|
||
{ exec.library functions }
|
||
|
||
{$include execf.inc}
|
||
{$include doslibf.inc}
|
||
|
||
|
||
{*****************************************************************************
|
||
System Dependent Structures/Consts
|
||
*****************************************************************************}
|
||
|
||
const
|
||
CTRL_C = 20; { Error code on CTRL-C press }
|
||
|
||
|
||
{*****************************************************************************
|
||
MorphOS File-handling Support Functions
|
||
*****************************************************************************}
|
||
type
|
||
{ AmigaOS does not automatically close opened files on exit back to }
|
||
{ the operating system, therefore as a precuation we close all files }
|
||
{ manually on exit. }
|
||
PFileList = ^TFileList;
|
||
TFileList = record { no packed, must be correctly aligned }
|
||
handle : LongInt; { Handle to file }
|
||
next : PFileList; { Next file in list }
|
||
end;
|
||
|
||
var
|
||
MOS_fileList: PFileList; { List pointer to opened files }
|
||
|
||
{ Function to be called at program shutdown, to close all opened files }
|
||
procedure CloseList(l: PFileList);
|
||
var
|
||
tmpNext : PFileList;
|
||
tmpHandle : LongInt;
|
||
begin
|
||
if l=nil then exit;
|
||
|
||
{ First, close all tracked files }
|
||
tmpNext:=l^.next;
|
||
while tmpNext<>nil do begin
|
||
tmpHandle:=tmpNext^.handle;
|
||
if (tmpHandle<>StdInputHandle) and (tmpHandle<>StdOutputHandle)
|
||
and (tmpHandle<>StdErrorHandle) then begin
|
||
Close2(tmpHandle);
|
||
end;
|
||
tmpNext:=tmpNext^.next;
|
||
end;
|
||
|
||
{ Next, erase the linked list }
|
||
while l<>nil do begin
|
||
tmpNext:=l;
|
||
l:=l^.next;
|
||
dispose(tmpNext);
|
||
end;
|
||
end;
|
||
|
||
{ Function to be called to add a file to the opened file list }
|
||
procedure AddToList(var l: PFileList; h: LongInt);
|
||
var
|
||
p : PFileList;
|
||
inList: Boolean;
|
||
begin
|
||
inList:=False;
|
||
if l<>nil then begin
|
||
{ if there is a valid filelist, search for the value }
|
||
{ in the list to avoid double additions }
|
||
p:=l;
|
||
while (p^.next<>nil) and (not inList) do
|
||
if p^.next^.handle=h then inList:=True
|
||
else p:=p^.next;
|
||
p:=nil;
|
||
end else begin
|
||
{ if the list is not yet allocated, allocate it. }
|
||
New(l);
|
||
l^.next:=nil;
|
||
end;
|
||
|
||
if not inList then begin
|
||
New(p);
|
||
p^.handle:=h;
|
||
p^.next:=l^.next;
|
||
l^.next:=p;
|
||
end;
|
||
end;
|
||
|
||
{ Function to be called to remove a file from the list }
|
||
procedure RemoveFromList(var l: PFileList; h: longint);
|
||
var
|
||
p : PFileList;
|
||
inList: Boolean;
|
||
begin
|
||
if l=nil then exit;
|
||
|
||
inList:=False;
|
||
p:=l;
|
||
while (p^.next<>nil) and (not inList) do
|
||
if p^.next^.handle=h then inList:=True
|
||
else p:=p^.next;
|
||
|
||
if p^.next<>nil then begin
|
||
dispose(p^.next);
|
||
p^.next:=p^.next^.next;
|
||
end;
|
||
end;
|
||
|
||
|
||
{*****************************************************************************
|
||
Misc. System Dependent Functions
|
||
*****************************************************************************}
|
||
|
||
procedure haltproc(e:longint);cdecl;external name '_haltproc';
|
||
|
||
procedure System_exit;
|
||
begin
|
||
{ We must remove the CTRL-C FALG here because halt }
|
||
{ may call I/O routines, which in turn might call }
|
||
{ halt, so a recursive stack crash }
|
||
if BreakOn then begin
|
||
if (SetSignal(0,0) and SIGBREAKF_CTRL_C)<>0 then
|
||
SetSignal(0,SIGBREAKF_CTRL_C);
|
||
end;
|
||
|
||
{ Closing opened files }
|
||
CloseList(MOS_fileList);
|
||
|
||
if MOS_UtilityBase<>nil then CloseLibrary(MOS_UtilityBase);
|
||
if MOS_DOSBase<>nil then CloseLibrary(MOS_DOSBase);
|
||
if MOS_heapPool<>nil then DeletePool(MOS_heapPool);
|
||
haltproc(ExitCode);
|
||
end;
|
||
|
||
{ Converts a MorphOS dos.library error code to a TP compatible error code }
|
||
{ Based on 1.0.x Amiga RTL }
|
||
procedure dosError2InOut(errno: LongInt);
|
||
begin
|
||
case errno of
|
||
ERROR_BAD_NUMBER,
|
||
ERROR_ACTION_NOT_KNOWN,
|
||
ERROR_NOT_IMPLEMENTED : InOutRes := 1;
|
||
|
||
ERROR_OBJECT_NOT_FOUND : InOutRes := 2;
|
||
ERROR_DIR_NOT_FOUND : InOutRes := 3;
|
||
ERROR_DISK_WRITE_PROTECTED : InOutRes := 150;
|
||
ERROR_OBJECT_WRONG_TYPE : InOutRes := 151;
|
||
|
||
ERROR_OBJECT_EXISTS,
|
||
ERROR_DELETE_PROTECTED,
|
||
ERROR_WRITE_PROTECTED,
|
||
ERROR_READ_PROTECTED,
|
||
ERROR_OBJECT_IN_USE,
|
||
ERROR_DIRECTORY_NOT_EMPTY : InOutRes := 5;
|
||
|
||
ERROR_NO_MORE_ENTRIES : InOutRes := 18;
|
||
ERROR_RENAME_ACROSS_DEVICES : InOutRes := 17;
|
||
ERROR_DISK_FULL : InOutRes := 101;
|
||
ERROR_INVALID_RESIDENT_LIBRARY : InoutRes := 153;
|
||
ERROR_BAD_HUNK : InOutRes := 153;
|
||
ERROR_NOT_A_DOS_DISK : InOutRes := 157;
|
||
|
||
ERROR_NO_DISK,
|
||
ERROR_DISK_NOT_VALIDATED,
|
||
ERROR_DEVICE_NOT_MOUNTED : InOutRes := 152;
|
||
|
||
ERROR_SEEK_ERROR : InOutRes := 156;
|
||
|
||
ERROR_LOCK_COLLISION,
|
||
ERROR_LOCK_TIMEOUT,
|
||
ERROR_UNLOCK_ERROR,
|
||
ERROR_INVALID_LOCK,
|
||
ERROR_INVALID_COMPONENT_NAME,
|
||
ERROR_BAD_STREAM_NAME,
|
||
ERROR_FILE_NOT_OBJECT : InOutRes := 6;
|
||
else
|
||
InOutres := errno;
|
||
end;
|
||
end;
|
||
|
||
{ Used for CTRL_C checking in I/O calls }
|
||
procedure checkCTRLC;
|
||
begin
|
||
if BreakOn then begin
|
||
if (SetSignal(0,0) And SIGBREAKF_CTRL_C)<>0 then begin
|
||
{ Clear CTRL-C signal }
|
||
SetSignal(0,SIGBREAKF_CTRL_C);
|
||
Halt(CTRL_C);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
{ Generates correct argument array on startup }
|
||
procedure GenerateArgs;
|
||
var
|
||
argvlen : longint;
|
||
|
||
procedure allocarg(idx,len:longint);
|
||
var
|
||
i,oldargvlen : longint;
|
||
begin
|
||
if idx>=argvlen then
|
||
begin
|
||
oldargvlen:=argvlen;
|
||
argvlen:=(idx+8) and (not 7);
|
||
sysreallocmem(argv,argvlen*sizeof(pointer));
|
||
for i:=oldargvlen to argvlen-1 do
|
||
argv[i]:=nil;
|
||
end;
|
||
{ use realloc to reuse already existing memory }
|
||
sysreallocmem(argv[idx],len+1);
|
||
end;
|
||
|
||
var
|
||
count: word;
|
||
start: word;
|
||
localindex: word;
|
||
p : pchar;
|
||
temp : string;
|
||
|
||
begin
|
||
p:=GetArgStr;
|
||
argvlen:=0;
|
||
|
||
{ Set argv[0] }
|
||
temp:=paramstr(0);
|
||
allocarg(0,length(temp));
|
||
move(temp[1],argv[0]^,length(temp));
|
||
argv[0][length(temp)]:=#0;
|
||
|
||
{ check if we're started from Ambient }
|
||
if MOS_ambMsg<>nil then
|
||
begin
|
||
argc:=0;
|
||
exit;
|
||
end;
|
||
|
||
{ Handle the other args }
|
||
count:=0;
|
||
{ first index is one }
|
||
localindex:=1;
|
||
while (p[count]<>#0) do
|
||
begin
|
||
while (p[count]=' ') or (p[count]=#9) or (p[count]=LineEnding) do inc(count);
|
||
start:=count;
|
||
while (p[count]<>#0) and (p[count]<>' ') and (p[count]<>#9) and (p[count]<>LineEnding) do inc(count);
|
||
if (count-start>0) then
|
||
begin
|
||
allocarg(localindex,count-start);
|
||
move(p[start],argv[localindex]^,count-start);
|
||
argv[localindex][count-start]:=#0;
|
||
inc(localindex);
|
||
end;
|
||
end;
|
||
argc:=localindex;
|
||
end;
|
||
|
||
function GetProgDir: String;
|
||
var
|
||
s1 : String;
|
||
alock : LongInt;
|
||
counter: Byte;
|
||
begin
|
||
GetProgDir:='';
|
||
FillChar(s1,255,#0);
|
||
{ GetLock of program directory }
|
||
alock:=GetProgramDir;
|
||
if alock<>0 then begin
|
||
if NameFromLock(alock,@s1[1],255) then begin
|
||
counter:=1;
|
||
while (s1[counter]<>#0) and (counter<>0) do Inc(counter);
|
||
s1[0]:=Char(counter-1);
|
||
GetProgDir:=s1;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function GetProgramName: String;
|
||
{ Returns ONLY the program name }
|
||
var
|
||
s1 : String;
|
||
counter: Byte;
|
||
begin
|
||
GetProgramName:='';
|
||
FillChar(s1,255,#0);
|
||
if GetProgramName(@s1[1],255) then begin
|
||
|
||
{ now check out and assign the length of the string }
|
||
counter := 1;
|
||
while (s1[counter]<>#0) and (counter<>0) do Inc(counter);
|
||
s1[0]:=Char(counter-1);
|
||
|
||
{ now remove any component path which should not be there }
|
||
for counter:=length(s1) downto 1 do
|
||
if (s1[counter] = '/') or (s1[counter] = ':') then break;
|
||
{ readjust counterv to point to character }
|
||
if counter<>1 then Inc(counter);
|
||
|
||
GetProgramName:=copy(s1,counter,length(s1));
|
||
end;
|
||
end;
|
||
|
||
|
||
{*****************************************************************************
|
||
ParamStr/Randomize
|
||
*****************************************************************************}
|
||
|
||
{ number of args }
|
||
function paramcount : longint;
|
||
begin
|
||
if MOS_ambMsg<>nil then
|
||
paramcount:=0
|
||
else
|
||
paramcount:=argc-1;
|
||
end;
|
||
|
||
{ argument number l }
|
||
function paramstr(l : longint) : string;
|
||
var
|
||
s1: String;
|
||
begin
|
||
paramstr:='';
|
||
if MOS_ambMsg<>nil then exit;
|
||
|
||
if l=0 then begin
|
||
s1:=GetProgDir;
|
||
if s1[length(s1)]=':' then paramstr:=s1+GetProgramName
|
||
else paramstr:=s1+'/'+GetProgramName;
|
||
end else begin
|
||
if (l>0) and (l+1<=argc) then paramstr:=strpas(argv[l]);
|
||
end;
|
||
end;
|
||
|
||
{ set randseed to a new pseudo random value }
|
||
procedure randomize;
|
||
var tmpTime: TDateStamp;
|
||
begin
|
||
DateStamp(tmpTime);
|
||
randseed:=tmpTime.ds_tick;
|
||
end;
|
||
|
||
|
||
{*****************************************************************************
|
||
Heap Management
|
||
*****************************************************************************}
|
||
|
||
var
|
||
int_heap : LongInt; external name 'HEAP';
|
||
int_heapsize : LongInt; external name 'HEAPSIZE';
|
||
|
||
{ first address of heap }
|
||
function getheapstart:pointer;
|
||
begin
|
||
getheapstart:=@int_heap;
|
||
end;
|
||
|
||
{ current length of heap }
|
||
function getheapsize:longint;
|
||
begin
|
||
getheapsize:=int_heapsize;
|
||
end;
|
||
|
||
{ function to allocate size bytes more for the program }
|
||
{ must return the first address of new data space or nil if fail }
|
||
function Sbrk(size : longint):pointer;
|
||
begin
|
||
Sbrk:=AllocPooled(MOS_heapPool,size);
|
||
end;
|
||
|
||
{*****************************************************************************
|
||
OS Memory allocation / deallocation
|
||
****************************************************************************}
|
||
|
||
function SysOSAlloc(size: ptrint): pointer;
|
||
begin
|
||
result := sbrk(size);
|
||
end;
|
||
|
||
{$define HAS_SYSOSFREE}
|
||
|
||
procedure SysOSFree(p: pointer; size: ptrint);
|
||
begin
|
||
FreePooled(MOS_heapPool,p,size);
|
||
end;
|
||
|
||
{$I heap.inc}
|
||
|
||
|
||
{*****************************************************************************
|
||
Directory Handling
|
||
*****************************************************************************}
|
||
procedure mkdir(const s : string);[IOCheck];
|
||
var
|
||
buffer : array[0..255] of char;
|
||
j : Integer;
|
||
tmpStr : string;
|
||
tmpLock : LongInt;
|
||
begin
|
||
checkCTRLC;
|
||
if (s='') or (InOutRes<>0) then exit;
|
||
tmpStr:=s;
|
||
|
||
for j:=1 to length(tmpStr) do
|
||
if tmpStr[j]='\' then tmpStr[j]:='/';
|
||
move(tmpStr[1],buffer,length(tmpStr));
|
||
buffer[length(tmpStr)]:=#0;
|
||
|
||
tmpLock:=CreateDir(buffer);
|
||
if tmpLock=0 then begin
|
||
dosError2InOut(IoErr);
|
||
exit;
|
||
end;
|
||
UnLock(tmpLock);
|
||
end;
|
||
|
||
procedure rmdir(const s : string);[IOCheck];
|
||
var
|
||
buffer : array[0..255] of char;
|
||
j : Integer;
|
||
tmpStr : string;
|
||
begin
|
||
checkCTRLC;
|
||
if (s='.') then InOutRes:=16;
|
||
If (s='') or (InOutRes<>0) then exit;
|
||
tmpStr:=s;
|
||
for j:=1 to length(tmpStr) do
|
||
if tmpStr[j] = '\' then tmpStr[j] := '/';
|
||
move(tmpStr[1],buffer,length(tmpStr));
|
||
buffer[length(tmpStr)]:=#0;
|
||
if not DeleteFile(buffer) then
|
||
dosError2InOut(IoErr);
|
||
end;
|
||
|
||
procedure chdir(const s : string);[IOCheck];
|
||
var
|
||
buffer : array[0..255] of char;
|
||
alock : LongInt;
|
||
FIB : PFileInfoBlock;
|
||
j : Integer;
|
||
tmpStr : string;
|
||
begin
|
||
checkCTRLC;
|
||
If (s='') or (InOutRes<>0) then exit;
|
||
tmpStr:=s;
|
||
|
||
for j:=1 to length(tmpStr) do
|
||
if tmpStr[j]='\' then tmpStr[j]:='/';
|
||
|
||
{ Return parent directory }
|
||
if s='..' then begin
|
||
getdir(0,tmpStr);
|
||
j:=length(tmpStr);
|
||
{ Look through the previous paths }
|
||
while (tmpStr[j]<>'/') and (tmpStr[j]<>':') and (j>0) do
|
||
dec(j);
|
||
if j>0 then
|
||
tmpStr:=copy(tmpStr,1,j);
|
||
end;
|
||
alock:=0;
|
||
|
||
move(tmpStr[1],buffer,length(tmpStr));
|
||
buffer[length(tmpStr)]:=#0;
|
||
{ Changing the directory is a pretty complicated affair }
|
||
{ 1) Obtain a lock on the directory }
|
||
{ 2) CurrentDir the lock }
|
||
alock:=Lock(buffer,SHARED_LOCK);
|
||
if alock=0 then begin
|
||
dosError2InOut(IoErr);
|
||
exit;
|
||
end;
|
||
|
||
FIB:=nil;
|
||
new(FIB);
|
||
|
||
if (Examine(alock,FIB)=True) and (FIB^.fib_DirEntryType>0) then begin
|
||
alock := CurrentDir(alock);
|
||
if MOS_OrigDir=0 then begin
|
||
MOS_OrigDir:=alock;
|
||
alock:=0;
|
||
end;
|
||
end;
|
||
|
||
if alock<>0 then Unlock(alock);
|
||
if assigned(FIB) then dispose(FIB)
|
||
end;
|
||
|
||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
||
var tmpbuf: array[0..255] of char;
|
||
begin
|
||
checkCTRLC;
|
||
Dir:='';
|
||
if not GetCurrentDirName(tmpbuf,256) then
|
||
dosError2InOut(IoErr)
|
||
else
|
||
Dir:=strpas(tmpbuf);
|
||
end;
|
||
|
||
|
||
{****************************************************************************
|
||
Low level File Routines
|
||
All these functions can set InOutRes on errors
|
||
****************************************************************************}
|
||
|
||
{ close a file from the handle value }
|
||
procedure do_close(handle : longint);
|
||
begin
|
||
RemoveFromList(MOS_fileList,handle);
|
||
{ Do _NOT_ check CTRL_C on Close, because it will conflict
|
||
with System_Exit! }
|
||
if not Close2(handle) then
|
||
dosError2InOut(IoErr);
|
||
end;
|
||
|
||
procedure do_erase(p : pchar);
|
||
begin
|
||
checkCTRLC;
|
||
if not DeleteFile(p) then
|
||
dosError2InOut(IoErr);
|
||
end;
|
||
|
||
procedure do_rename(p1,p2 : pchar);
|
||
begin
|
||
checkCTRLC;
|
||
if not Rename2(p1,p2) then
|
||
dosError2InOut(IoErr);
|
||
end;
|
||
|
||
function do_write(h:longint; addr: pointer; len: longint) : longint;
|
||
var dosResult: LongInt;
|
||
begin
|
||
checkCTRLC;
|
||
do_write:=0;
|
||
if len<=0 then exit;
|
||
|
||
dosResult:=Write2(h,addr,len);
|
||
if dosResult<0 then begin
|
||
dosError2InOut(IoErr);
|
||
end else begin
|
||
do_write:=dosResult;
|
||
end;
|
||
end;
|
||
|
||
function do_read(h:longint; addr: pointer; len: longint) : longint;
|
||
var dosResult: LongInt;
|
||
begin
|
||
checkCTRLC;
|
||
do_read:=0;
|
||
if len<=0 then exit;
|
||
|
||
dosResult:=Read2(h,addr,len);
|
||
if dosResult<0 then begin
|
||
dosError2InOut(IoErr);
|
||
end else begin
|
||
do_read:=dosResult;
|
||
end
|
||
end;
|
||
|
||
function do_filepos(handle : longint) : longint;
|
||
var dosResult: LongInt;
|
||
begin
|
||
checkCTRLC;
|
||
do_filepos:=0;
|
||
|
||
{ Seeking zero from OFFSET_CURRENT to find out where we are }
|
||
dosResult:=Seek2(handle,0,OFFSET_CURRENT);
|
||
if dosResult<0 then begin
|
||
dosError2InOut(IoErr);
|
||
end else begin
|
||
do_filepos:=dosResult;
|
||
end;
|
||
end;
|
||
|
||
procedure do_seek(handle,pos : longint);
|
||
begin
|
||
checkCTRLC;
|
||
{ Seeking from OFFSET_BEGINNING }
|
||
if Seek2(handle,pos,OFFSET_BEGINNING)<0 then
|
||
dosError2InOut(IoErr);
|
||
end;
|
||
|
||
function do_seekend(handle:longint):longint;
|
||
var dosResult: LongInt;
|
||
begin
|
||
checkCTRLC;
|
||
do_seekend:=0;
|
||
|
||
{ Seeking to OFFSET_END }
|
||
dosResult:=Seek2(handle,0,OFFSET_END);
|
||
if dosResult<0 then begin
|
||
dosError2InOut(IoErr);
|
||
end else begin
|
||
do_seekend:=dosResult;
|
||
end
|
||
end;
|
||
|
||
function do_filesize(handle : longint) : longint;
|
||
var currfilepos: longint;
|
||
begin
|
||
checkCTRLC;
|
||
currfilepos:=do_filepos(handle);
|
||
{ We have to do this twice, because seek returns the OLD position }
|
||
do_filesize:=do_seekend(handle);
|
||
do_filesize:=do_seekend(handle);
|
||
do_seek(handle,currfilepos)
|
||
end;
|
||
|
||
{ truncate at a given position }
|
||
procedure do_truncate (handle,pos:longint);
|
||
begin
|
||
checkCTRLC;
|
||
{ Seeking from OFFSET_BEGINNING }
|
||
if SetFileSize(handle,pos,OFFSET_BEGINNING)<0 then
|
||
dosError2InOut(IoErr);
|
||
end;
|
||
|
||
procedure do_open(var f;p:pchar;flags:longint);
|
||
{
|
||
filerec and textrec have both handle and mode as the first items so
|
||
they could use the same routine for opening/creating.
|
||
when (flags and $10) the file will be append
|
||
when (flags and $100) the file will be truncate/rewritten
|
||
when (flags and $1000) there is no check for close (needed for textfiles)
|
||
}
|
||
var
|
||
i,j : LongInt;
|
||
openflags : LongInt;
|
||
path : String;
|
||
buffer : array[0..255] of Char;
|
||
index : Integer;
|
||
s : String;
|
||
begin
|
||
path:=strpas(p);
|
||
for index:=1 to length(path) do
|
||
if path[index]='\' then path[index]:='/';
|
||
{ remove any dot characters and replace by their current }
|
||
{ directory equivalent. }
|
||
|
||
{ look for parent directory }
|
||
if pos('../',path) = 1 then
|
||
begin
|
||
delete(path,1,3);
|
||
getdir(0,s);
|
||
j:=length(s);
|
||
while (s[j]<>'/') and (s[j]<>':') and (j>0) do
|
||
dec(j);
|
||
if j > 0 then
|
||
s:=copy(s,1,j);
|
||
path:=s+path;
|
||
end
|
||
else
|
||
|
||
{ look for current directory }
|
||
if pos('./',path) = 1 then
|
||
begin
|
||
delete(path,1,2);
|
||
getdir(0,s);
|
||
if (s[length(s)]<>'/') and (s[length(s)]<>':') then
|
||
s:=s+'/';
|
||
path:=s+path;
|
||
end;
|
||
|
||
move(path[1],buffer,length(path));
|
||
buffer[length(path)]:=#0;
|
||
|
||
{ close first if opened }
|
||
if ((flags and $10000)=0) then
|
||
begin
|
||
case filerec(f).mode of
|
||
fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
|
||
fmclosed : ;
|
||
else begin
|
||
inoutres:=102; {not assigned}
|
||
exit;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
{ reset file handle }
|
||
filerec(f).handle:=UnusedHandle;
|
||
|
||
{ convert filemode to filerec modes }
|
||
{ READ/WRITE on existing file }
|
||
{ RESET/APPEND }
|
||
openflags := 1005;
|
||
case (flags and 3) of
|
||
0 : filerec(f).mode:=fminput;
|
||
1 : filerec(f).mode:=fmoutput;
|
||
2 : filerec(f).mode:=fminout;
|
||
end;
|
||
|
||
{ rewrite (create a new file) }
|
||
if (flags and $1000)<>0 then openflags := 1006;
|
||
|
||
{ empty name is special }
|
||
if p[0]=#0 then
|
||
begin
|
||
case filerec(f).mode of
|
||
fminput :
|
||
filerec(f).handle:=StdInputHandle;
|
||
fmappend,
|
||
fmoutput : begin
|
||
filerec(f).handle:=StdOutputHandle;
|
||
filerec(f).mode:=fmoutput; {fool fmappend}
|
||
end;
|
||
end;
|
||
exit;
|
||
end;
|
||
|
||
i:=Open(buffer,openflags);
|
||
if i=0 then
|
||
begin
|
||
dosError2InOut(IoErr);
|
||
end else begin
|
||
AddToList(MOS_fileList,i);
|
||
filerec(f).handle:=i;
|
||
end;
|
||
|
||
{ append mode }
|
||
if ((Flags and $100)<>0) and (FileRec(F).Handle<>UnusedHandle) then
|
||
begin
|
||
do_seekend(filerec(f).handle);
|
||
filerec(f).mode:=fmoutput; {fool fmappend}
|
||
end;
|
||
end;
|
||
|
||
function do_isdevice(handle:longint):boolean;
|
||
begin
|
||
if (handle=StdOutputHandle) or (handle=StdInputHandle) or
|
||
(handle=StdErrorHandle) then
|
||
do_isdevice:=True
|
||
else
|
||
do_isdevice:=False;
|
||
end;
|
||
|
||
{*****************************************************************************
|
||
UnTyped File Handling
|
||
*****************************************************************************}
|
||
|
||
{$i file.inc}
|
||
|
||
{*****************************************************************************
|
||
Typed File Handling
|
||
*****************************************************************************}
|
||
|
||
{$i typefile.inc}
|
||
|
||
{*****************************************************************************
|
||
Text File Handling
|
||
*****************************************************************************}
|
||
|
||
{$I text.inc}
|
||
|
||
|
||
{ MorphOS specific startup }
|
||
procedure SysInitMorphOS;
|
||
var self: PProcess;
|
||
begin
|
||
self:=PProcess(FindTask(nil));
|
||
if self^.pr_CLI=0 then begin
|
||
{ if we're running from Ambient/Workbench, we catch its message }
|
||
WaitPort(@self^.pr_MsgPort);
|
||
MOS_ambMsg:=GetMsg(@self^.pr_MsgPort);
|
||
end;
|
||
|
||
MOS_DOSBase:=OpenLibrary('dos.library',50);
|
||
if MOS_DOSBase=nil then Halt(1);
|
||
MOS_UtilityBase:=OpenLibrary('utility.library',50);
|
||
if MOS_UtilityBase=nil then Halt(1);
|
||
|
||
{ Creating the memory pool for growing heap }
|
||
MOS_heapPool:=CreatePool(MEMF_FAST,growheapsize2,growheapsize1);
|
||
if MOS_heapPool=nil then Halt(1);
|
||
|
||
if MOS_ambMsg=nil then begin
|
||
StdInputHandle:=Input2;
|
||
StdOutputHandle:=Output2;
|
||
end else begin
|
||
MOS_ConHandle:=Open(MOS_ConName,1005);
|
||
if MOS_ConHandle<>0 then begin
|
||
StdInputHandle:=MOS_ConHandle;
|
||
StdOutputHandle:=MOS_ConHandle;
|
||
end else
|
||
Halt(1);
|
||
end;
|
||
end;
|
||
|
||
|
||
procedure SysInitStdIO;
|
||
begin
|
||
OpenStdIO(Input,fmInput,StdInputHandle);
|
||
OpenStdIO(Output,fmOutput,StdOutputHandle);
|
||
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
|
||
|
||
{ * MorphOS doesn't have a separate stderr, just like AmigaOS (???) * }
|
||
StdErrorHandle:=StdOutputHandle;
|
||
// OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
||
end;
|
||
|
||
|
||
begin
|
||
IsConsole := TRUE;
|
||
IsLibrary := FALSE;
|
||
StackLength := InitialStkLen;
|
||
StackBottom := Sptr - StackLength;
|
||
{ OS specific startup }
|
||
MOS_ambMsg:=nil;
|
||
MOS_origDir:=0;
|
||
MOS_fileList:=nil;
|
||
envp:=nil;
|
||
SysInitMorphOS;
|
||
{ Set up signals handlers }
|
||
// InstallSignals;
|
||
{ Setup heap }
|
||
InitHeap;
|
||
SysInitExceptions;
|
||
{ Setup stdin, stdout and stderr }
|
||
SysInitStdIO;
|
||
{ Reset IO Error }
|
||
InOutRes:=0;
|
||
{ Arguments }
|
||
GenerateArgs;
|
||
(* This should be changed to a real value during *)
|
||
(* thread driver initialization if appropriate. *)
|
||
ThreadID := 1;
|
||
{$ifdef HASVARIANT}
|
||
initvariantmanager;
|
||
{$endif HASVARIANT}
|
||
end.
|
||
|
||
{
|
||
$Log$
|
||
Revision 1.17 2004-08-03 15:59:41 karoly
|
||
* more cleanup & more includes
|
||
|
||
Revision 1.16 2004/06/26 20:48:24 karoly
|
||
* more cleanup + changes to use new includes
|
||
|
||
Revision 1.15 2004/06/23 13:27:32 karoly
|
||
* fixed system unit for the new heap manager
|
||
|
||
Revision 1.14 2004/06/17 16:16:14 peter
|
||
* New heapmanager that releases memory back to the OS, donated
|
||
by Micha Nelissen
|
||
|
||
Revision 1.13 2004/06/13 22:50:47 karoly
|
||
* cleanup and changes to use new includes
|
||
|
||
Revision 1.12 2004/06/06 23:31:13 karoly
|
||
* fixed dos_UnLockDosList from being nonsense, and some cleanup
|
||
|
||
Revision 1.11 2004/06/06 19:18:05 karoly
|
||
+ added support for paramstr(0)
|
||
|
||
Revision 1.10 2004/06/05 19:49:19 karoly
|
||
+ added console I/O support when running from Ambient
|
||
|
||
Revision 1.9 2004/05/12 23:18:54 karoly
|
||
* fixed do_read and dos_Read from being nonsense
|
||
|
||
Revision 1.8 2004/05/12 20:26:04 karoly
|
||
+ added syscalls and structures necessary for DOS unit
|
||
|
||
Revision 1.7 2004/05/12 15:34:16 karoly
|
||
* fixed startup code from endless wait when not started from Ambient
|
||
|
||
Revision 1.6 2004/05/09 14:42:59 karoly
|
||
* again, few more new things added
|
||
|
||
Revision 1.5 2004/05/09 02:02:42 karoly
|
||
* more things got implemented
|
||
|
||
Revision 1.4 2004/05/02 02:06:57 karoly
|
||
+ most of file I/O calls implemented
|
||
|
||
Revision 1.3 2004/05/01 15:09:47 karoly
|
||
* first working system unit (very limited yet)
|
||
|
||
Revision 1.2 <20>2004/04/08 06:28:29 <20>karoly
|
||
* first steps to have a morphos system unit
|
||
|
||
Revision 1.1 2004/02/13 07:19:53 karoly
|
||
* quick hack from Linux system unit
|
||
}
|