system.pp 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 2004 by Karoly Balogh for Genesi S.a.r.l.
  5. System unit for MorphOS/PowerPC
  6. Uses parts of the Commodore Amiga/68k port by Carl Eric Codere
  7. and Nils Sjoholm
  8. MorphOS port was done on a free Pegasos II/G4 machine
  9. provided by Genesi S.a.r.l. <www.genesi.lu>
  10. See the file COPYING.FPC, included in this distribution,
  11. for details about the copyright.
  12. This program is distributed in the hope that it will be useful,
  13. but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  15. **********************************************************************}
  16. unit {$ifdef VER1_0}SysMorph{$else}System{$endif};
  17. interface
  18. {$define FPC_IS_SYSTEM}
  19. {$I systemh.inc}
  20. type
  21. THandle = LongInt;
  22. {$I heaph.inc}
  23. const
  24. LineEnding = #10;
  25. LFNSupport = True;
  26. DirectorySeparator = '/';
  27. DriveSeparator = ':';
  28. PathSeparator = ';';
  29. maxExitCode = 255;
  30. const
  31. UnusedHandle : LongInt = -1;
  32. StdInputHandle : LongInt = 0;
  33. StdOutputHandle : LongInt = 0;
  34. StdErrorHandle : LongInt = 0;
  35. FileNameCaseSensitive : Boolean = False;
  36. sLineBreak : string[1] = LineEnding;
  37. DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF;
  38. BreakOn : Boolean = True;
  39. var
  40. MOS_ExecBase : Pointer; external name '_ExecBase';
  41. MOS_DOSBase : Pointer;
  42. MOS_UtilityBase: Pointer;
  43. MOS_heapPool : Pointer; { pointer for the OS pool for growing the heap }
  44. MOS_origDir : LongInt; { original directory on startup }
  45. MOS_currDir : LongInt; { current directory handle }
  46. MOS_ambMsg : Pointer;
  47. MOS_ConName : PChar ='CON:10/30/620/100/FPC Console Output/AUTO/CLOSE/WAIT';
  48. MOS_ConHandle: LongInt;
  49. argc: LongInt;
  50. argv: PPChar;
  51. envp: PPChar;
  52. implementation
  53. {$I system.inc}
  54. {*****************************************************************************
  55. MorphOS structures
  56. *****************************************************************************}
  57. {$include execd.inc}
  58. {$include timerd.inc}
  59. {$include doslibd.inc}
  60. {*****************************************************************************
  61. MorphOS functions
  62. *****************************************************************************}
  63. { exec.library functions }
  64. {$include execf.inc}
  65. {$include doslibf.inc}
  66. {*****************************************************************************
  67. System Dependent Structures/Consts
  68. *****************************************************************************}
  69. const
  70. CTRL_C = 20; { Error code on CTRL-C press }
  71. {*****************************************************************************
  72. MorphOS File-handling Support Functions
  73. *****************************************************************************}
  74. type
  75. { AmigaOS does not automatically close opened files on exit back to }
  76. { the operating system, therefore as a precuation we close all files }
  77. { manually on exit. }
  78. PFileList = ^TFileList;
  79. TFileList = record { no packed, must be correctly aligned }
  80. handle : LongInt; { Handle to file }
  81. next : PFileList; { Next file in list }
  82. end;
  83. var
  84. MOS_fileList: PFileList; { List pointer to opened files }
  85. { Function to be called at program shutdown, to close all opened files }
  86. procedure CloseList(l: PFileList);
  87. var
  88. tmpNext : PFileList;
  89. tmpHandle : LongInt;
  90. begin
  91. if l=nil then exit;
  92. { First, close all tracked files }
  93. tmpNext:=l^.next;
  94. while tmpNext<>nil do begin
  95. tmpHandle:=tmpNext^.handle;
  96. if (tmpHandle<>StdInputHandle) and (tmpHandle<>StdOutputHandle)
  97. and (tmpHandle<>StdErrorHandle) then begin
  98. dosClose(tmpHandle);
  99. end;
  100. tmpNext:=tmpNext^.next;
  101. end;
  102. { Next, erase the linked list }
  103. while l<>nil do begin
  104. tmpNext:=l;
  105. l:=l^.next;
  106. dispose(tmpNext);
  107. end;
  108. end;
  109. { Function to be called to add a file to the opened file list }
  110. procedure AddToList(var l: PFileList; h: LongInt);
  111. var
  112. p : PFileList;
  113. inList: Boolean;
  114. begin
  115. inList:=False;
  116. if l<>nil then begin
  117. { if there is a valid filelist, search for the value }
  118. { in the list to avoid double additions }
  119. p:=l;
  120. while (p^.next<>nil) and (not inList) do
  121. if p^.next^.handle=h then inList:=True
  122. else p:=p^.next;
  123. p:=nil;
  124. end else begin
  125. { if the list is not yet allocated, allocate it. }
  126. New(l);
  127. l^.next:=nil;
  128. end;
  129. if not inList then begin
  130. New(p);
  131. p^.handle:=h;
  132. p^.next:=l^.next;
  133. l^.next:=p;
  134. end;
  135. end;
  136. { Function to be called to remove a file from the list }
  137. procedure RemoveFromList(var l: PFileList; h: longint);
  138. var
  139. p : PFileList;
  140. inList: Boolean;
  141. begin
  142. if l=nil then exit;
  143. inList:=False;
  144. p:=l;
  145. while (p^.next<>nil) and (not inList) do
  146. if p^.next^.handle=h then inList:=True
  147. else p:=p^.next;
  148. if p^.next<>nil then begin
  149. dispose(p^.next);
  150. p^.next:=p^.next^.next;
  151. end;
  152. end;
  153. {*****************************************************************************
  154. Misc. System Dependent Functions
  155. *****************************************************************************}
  156. procedure haltproc(e:longint);cdecl;external name '_haltproc';
  157. procedure System_exit;
  158. begin
  159. { We must remove the CTRL-C FLAG here because halt }
  160. { may call I/O routines, which in turn might call }
  161. { halt, so a recursive stack crash }
  162. if BreakOn then begin
  163. if (SetSignal(0,0) and SIGBREAKF_CTRL_C)<>0 then
  164. SetSignal(0,SIGBREAKF_CTRL_C);
  165. end;
  166. { Closing opened files }
  167. CloseList(MOS_fileList);
  168. { Changing back to original directory if changed }
  169. if MOS_origDir<>0 then begin
  170. CurrentDir(MOS_origDir);
  171. end;
  172. if MOS_UtilityBase<>nil then CloseLibrary(MOS_UtilityBase);
  173. if MOS_DOSBase<>nil then CloseLibrary(MOS_DOSBase);
  174. if MOS_heapPool<>nil then DeletePool(MOS_heapPool);
  175. haltproc(ExitCode);
  176. end;
  177. { Converts a MorphOS dos.library error code to a TP compatible error code }
  178. { Based on 1.0.x Amiga RTL }
  179. procedure dosError2InOut(errno: LongInt);
  180. begin
  181. case errno of
  182. ERROR_BAD_NUMBER,
  183. ERROR_ACTION_NOT_KNOWN,
  184. ERROR_NOT_IMPLEMENTED : InOutRes := 1;
  185. ERROR_OBJECT_NOT_FOUND : InOutRes := 2;
  186. ERROR_DIR_NOT_FOUND : InOutRes := 3;
  187. ERROR_DISK_WRITE_PROTECTED : InOutRes := 150;
  188. ERROR_OBJECT_WRONG_TYPE : InOutRes := 151;
  189. ERROR_OBJECT_EXISTS,
  190. ERROR_DELETE_PROTECTED,
  191. ERROR_WRITE_PROTECTED,
  192. ERROR_READ_PROTECTED,
  193. ERROR_OBJECT_IN_USE,
  194. ERROR_DIRECTORY_NOT_EMPTY : InOutRes := 5;
  195. ERROR_NO_MORE_ENTRIES : InOutRes := 18;
  196. ERROR_RENAME_ACROSS_DEVICES : InOutRes := 17;
  197. ERROR_DISK_FULL : InOutRes := 101;
  198. ERROR_INVALID_RESIDENT_LIBRARY : InoutRes := 153;
  199. ERROR_BAD_HUNK : InOutRes := 153;
  200. ERROR_NOT_A_DOS_DISK : InOutRes := 157;
  201. ERROR_NO_DISK,
  202. ERROR_DISK_NOT_VALIDATED,
  203. ERROR_DEVICE_NOT_MOUNTED : InOutRes := 152;
  204. ERROR_SEEK_ERROR : InOutRes := 156;
  205. ERROR_LOCK_COLLISION,
  206. ERROR_LOCK_TIMEOUT,
  207. ERROR_UNLOCK_ERROR,
  208. ERROR_INVALID_LOCK,
  209. ERROR_INVALID_COMPONENT_NAME,
  210. ERROR_BAD_STREAM_NAME,
  211. ERROR_FILE_NOT_OBJECT : InOutRes := 6;
  212. else
  213. InOutres := errno;
  214. end;
  215. end;
  216. { Used for CTRL_C checking in I/O calls }
  217. procedure checkCTRLC;
  218. begin
  219. if BreakOn then begin
  220. if (SetSignal(0,0) And SIGBREAKF_CTRL_C)<>0 then begin
  221. { Clear CTRL-C signal }
  222. SetSignal(0,SIGBREAKF_CTRL_C);
  223. Halt(CTRL_C);
  224. end;
  225. end;
  226. end;
  227. { Generates correct argument array on startup }
  228. procedure GenerateArgs;
  229. var
  230. argvlen : longint;
  231. procedure allocarg(idx,len:longint);
  232. var
  233. i,oldargvlen : longint;
  234. begin
  235. if idx>=argvlen then
  236. begin
  237. oldargvlen:=argvlen;
  238. argvlen:=(idx+8) and (not 7);
  239. sysreallocmem(argv,argvlen*sizeof(pointer));
  240. for i:=oldargvlen to argvlen-1 do
  241. argv[i]:=nil;
  242. end;
  243. { use realloc to reuse already existing memory }
  244. sysreallocmem(argv[idx],len+1);
  245. end;
  246. var
  247. count: word;
  248. start: word;
  249. localindex: word;
  250. p : pchar;
  251. temp : string;
  252. begin
  253. p:=GetArgStr;
  254. argvlen:=0;
  255. { Set argv[0] }
  256. temp:=paramstr(0);
  257. allocarg(0,length(temp));
  258. move(temp[1],argv[0]^,length(temp));
  259. argv[0][length(temp)]:=#0;
  260. { check if we're started from Ambient }
  261. if MOS_ambMsg<>nil then
  262. begin
  263. argc:=0;
  264. exit;
  265. end;
  266. { Handle the other args }
  267. count:=0;
  268. { first index is one }
  269. localindex:=1;
  270. while (p[count]<>#0) do
  271. begin
  272. while (p[count]=' ') or (p[count]=#9) or (p[count]=LineEnding) do inc(count);
  273. start:=count;
  274. while (p[count]<>#0) and (p[count]<>' ') and (p[count]<>#9) and (p[count]<>LineEnding) do inc(count);
  275. if (count-start>0) then
  276. begin
  277. allocarg(localindex,count-start);
  278. move(p[start],argv[localindex]^,count-start);
  279. argv[localindex][count-start]:=#0;
  280. inc(localindex);
  281. end;
  282. end;
  283. argc:=localindex;
  284. end;
  285. function GetProgDir: String;
  286. var
  287. s1 : String;
  288. alock : LongInt;
  289. counter: Byte;
  290. begin
  291. GetProgDir:='';
  292. FillChar(s1,255,#0);
  293. { GetLock of program directory }
  294. alock:=GetProgramDir;
  295. if alock<>0 then begin
  296. if NameFromLock(alock,@s1[1],255) then begin
  297. counter:=1;
  298. while (s1[counter]<>#0) and (counter<>0) do Inc(counter);
  299. s1[0]:=Char(counter-1);
  300. GetProgDir:=s1;
  301. end;
  302. end;
  303. end;
  304. function GetProgramName: String;
  305. { Returns ONLY the program name }
  306. var
  307. s1 : String;
  308. counter: Byte;
  309. begin
  310. GetProgramName:='';
  311. FillChar(s1,255,#0);
  312. if GetProgramName(@s1[1],255) then begin
  313. { now check out and assign the length of the string }
  314. counter := 1;
  315. while (s1[counter]<>#0) and (counter<>0) do Inc(counter);
  316. s1[0]:=Char(counter-1);
  317. { now remove any component path which should not be there }
  318. for counter:=length(s1) downto 1 do
  319. if (s1[counter] = '/') or (s1[counter] = ':') then break;
  320. { readjust counterv to point to character }
  321. if counter<>1 then Inc(counter);
  322. GetProgramName:=copy(s1,counter,length(s1));
  323. end;
  324. end;
  325. { Converts an Unix-like path to Amiga-like path }
  326. function PathConv(path: string): string; alias: 'PATHCONV'; [public];
  327. var tmppos: longint;
  328. begin
  329. { check for short paths }
  330. if length(path)<=2 then begin
  331. if (path='.') or (path='./') then path:='' else
  332. if path='..' then path:='/' else
  333. if path='*' then path:='#?';
  334. end else begin
  335. { convert parent directories }
  336. tmppos:=pos('../',path);
  337. while tmppos<>0 do begin
  338. { delete .. to have / as parent dir sign }
  339. delete(path,tmppos,2);
  340. tmppos:=pos('../',path);
  341. end;
  342. { convert current directories }
  343. tmppos:=pos('./',path);
  344. while tmppos<>0 do begin
  345. { delete ./ since we doesn't need to sign current directory }
  346. delete(path,tmppos,2);
  347. tmppos:=pos('./',path);
  348. end;
  349. { convert wildstart to #? }
  350. tmppos:=pos('*',path);
  351. while tmppos<>0 do begin
  352. delete(path,tmppos,1);
  353. insert('#?',path,tmppos);
  354. tmppos:=pos('*',path);
  355. end;
  356. end;
  357. PathConv:=path;
  358. end;
  359. {*****************************************************************************
  360. ParamStr/Randomize
  361. *****************************************************************************}
  362. { number of args }
  363. function paramcount : longint;
  364. begin
  365. if MOS_ambMsg<>nil then
  366. paramcount:=0
  367. else
  368. paramcount:=argc-1;
  369. end;
  370. { argument number l }
  371. function paramstr(l : longint) : string;
  372. var
  373. s1: String;
  374. begin
  375. paramstr:='';
  376. if MOS_ambMsg<>nil then exit;
  377. if l=0 then begin
  378. s1:=GetProgDir;
  379. if s1[length(s1)]=':' then paramstr:=s1+GetProgramName
  380. else paramstr:=s1+'/'+GetProgramName;
  381. end else begin
  382. if (l>0) and (l+1<=argc) then paramstr:=strpas(argv[l]);
  383. end;
  384. end;
  385. { set randseed to a new pseudo random value }
  386. procedure randomize;
  387. var tmpTime: TDateStamp;
  388. begin
  389. DateStamp(@tmpTime);
  390. randseed:=tmpTime.ds_tick;
  391. end;
  392. {*****************************************************************************
  393. OS Memory allocation / deallocation
  394. ****************************************************************************}
  395. function SysOSAlloc(size: ptrint): pointer;
  396. begin
  397. result := AllocPooled(MOS_heapPool,size);
  398. end;
  399. {$define HAS_SYSOSFREE}
  400. procedure SysOSFree(p: pointer; size: ptrint);
  401. begin
  402. FreePooled(MOS_heapPool,p,size);
  403. end;
  404. {$I heap.inc}
  405. {*****************************************************************************
  406. Directory Handling
  407. *****************************************************************************}
  408. procedure mkdir(const s : string);[IOCheck];
  409. var
  410. tmpStr : array[0..255] of char;
  411. tmpLock: LongInt;
  412. begin
  413. checkCTRLC;
  414. if (s='') or (InOutRes<>0) then exit;
  415. tmpStr:=PathConv(s)+#0;
  416. tmpLock:=CreateDir(@tmpStr);
  417. if tmpLock=0 then begin
  418. dosError2InOut(IoErr);
  419. exit;
  420. end;
  421. UnLock(tmpLock);
  422. end;
  423. procedure rmdir(const s : string);[IOCheck];
  424. var
  425. tmpStr : array[0..255] of Char;
  426. begin
  427. checkCTRLC;
  428. if (s='.') then InOutRes:=16;
  429. If (s='') or (InOutRes<>0) then exit;
  430. tmpStr:=PathConv(s)+#0;
  431. if not DeleteFile(@tmpStr) then
  432. dosError2InOut(IoErr);
  433. end;
  434. procedure chdir(const s : string);[IOCheck];
  435. var
  436. tmpStr : array[0..255] of Char;
  437. tmpLock: LongInt;
  438. FIB : PFileInfoBlock;
  439. begin
  440. checkCTRLC;
  441. If (s='') or (InOutRes<>0) then exit;
  442. tmpStr:=PathConv(s)+#0;
  443. tmpLock:=0;
  444. { Changing the directory is a pretty complicated affair }
  445. { 1) Obtain a lock on the directory }
  446. { 2) CurrentDir the lock }
  447. writeln('locking: >>',tmpStr,'<<');
  448. tmpLock:=Lock(@tmpStr,SHARED_LOCK);
  449. if tmpLock=0 then begin
  450. dosError2InOut(IoErr);
  451. exit;
  452. end;
  453. FIB:=nil;
  454. new(FIB);
  455. if (Examine(tmpLock,FIB)=True) and (FIB^.fib_DirEntryType>0) then begin
  456. tmpLock:=CurrentDir(tmpLock);
  457. if MOS_OrigDir=0 then begin
  458. MOS_OrigDir:=tmpLock;
  459. tmpLock:=0;
  460. end;
  461. end;
  462. if tmpLock<>0 then Unlock(tmpLock);
  463. if assigned(FIB) then dispose(FIB);
  464. end;
  465. procedure GetDir (DriveNr: byte; var Dir: ShortString);
  466. var tmpbuf: array[0..255] of char;
  467. begin
  468. checkCTRLC;
  469. Dir:='';
  470. if not GetCurrentDirName(tmpbuf,256) then
  471. dosError2InOut(IoErr)
  472. else
  473. Dir:=strpas(tmpbuf);
  474. end;
  475. {****************************************************************************
  476. Low level File Routines
  477. All these functions can set InOutRes on errors
  478. ****************************************************************************}
  479. { close a file from the handle value }
  480. procedure do_close(handle : longint);
  481. begin
  482. RemoveFromList(MOS_fileList,handle);
  483. { Do _NOT_ check CTRL_C on Close, because it will conflict
  484. with System_Exit! }
  485. if not dosClose(handle) then
  486. dosError2InOut(IoErr);
  487. end;
  488. procedure do_erase(p : pchar);
  489. begin
  490. checkCTRLC;
  491. if not DeleteFile(p) then
  492. dosError2InOut(IoErr);
  493. end;
  494. procedure do_rename(p1,p2 : pchar);
  495. begin
  496. checkCTRLC;
  497. if not dosRename(p1,p2) then
  498. dosError2InOut(IoErr);
  499. end;
  500. function do_write(h:longint; addr: pointer; len: longint) : longint;
  501. var dosResult: LongInt;
  502. begin
  503. checkCTRLC;
  504. do_write:=0;
  505. if len<=0 then exit;
  506. dosResult:=dosWrite(h,addr,len);
  507. if dosResult<0 then begin
  508. dosError2InOut(IoErr);
  509. end else begin
  510. do_write:=dosResult;
  511. end;
  512. end;
  513. function do_read(h:longint; addr: pointer; len: longint) : longint;
  514. var dosResult: LongInt;
  515. begin
  516. checkCTRLC;
  517. do_read:=0;
  518. if len<=0 then exit;
  519. dosResult:=dosRead(h,addr,len);
  520. if dosResult<0 then begin
  521. dosError2InOut(IoErr);
  522. end else begin
  523. do_read:=dosResult;
  524. end
  525. end;
  526. function do_filepos(handle : longint) : longint;
  527. var dosResult: LongInt;
  528. begin
  529. checkCTRLC;
  530. do_filepos:=0;
  531. { Seeking zero from OFFSET_CURRENT to find out where we are }
  532. dosResult:=dosSeek(handle,0,OFFSET_CURRENT);
  533. if dosResult<0 then begin
  534. dosError2InOut(IoErr);
  535. end else begin
  536. do_filepos:=dosResult;
  537. end;
  538. end;
  539. procedure do_seek(handle,pos : longint);
  540. begin
  541. checkCTRLC;
  542. { Seeking from OFFSET_BEGINNING }
  543. if dosSeek(handle,pos,OFFSET_BEGINNING)<0 then
  544. dosError2InOut(IoErr);
  545. end;
  546. function do_seekend(handle:longint):longint;
  547. var dosResult: LongInt;
  548. begin
  549. checkCTRLC;
  550. do_seekend:=0;
  551. { Seeking to OFFSET_END }
  552. dosResult:=dosSeek(handle,0,OFFSET_END);
  553. if dosResult<0 then begin
  554. dosError2InOut(IoErr);
  555. end else begin
  556. do_seekend:=dosResult;
  557. end
  558. end;
  559. function do_filesize(handle : longint) : longint;
  560. var currfilepos: longint;
  561. begin
  562. checkCTRLC;
  563. currfilepos:=do_filepos(handle);
  564. { We have to do this twice, because seek returns the OLD position }
  565. do_filesize:=do_seekend(handle);
  566. do_filesize:=do_seekend(handle);
  567. do_seek(handle,currfilepos)
  568. end;
  569. { truncate at a given position }
  570. procedure do_truncate (handle,pos:longint);
  571. begin
  572. checkCTRLC;
  573. { Seeking from OFFSET_BEGINNING }
  574. if SetFileSize(handle,pos,OFFSET_BEGINNING)<0 then
  575. dosError2InOut(IoErr);
  576. end;
  577. procedure do_open(var f;p:pchar;flags:longint);
  578. {
  579. filerec and textrec have both handle and mode as the first items so
  580. they could use the same routine for opening/creating.
  581. when (flags and $10) the file will be append
  582. when (flags and $100) the file will be truncate/rewritten
  583. when (flags and $1000) there is no check for close (needed for textfiles)
  584. }
  585. var
  586. handle : LongInt;
  587. openflags: LongInt;
  588. tmpStr : array[0..255] of Char;
  589. begin
  590. tmpStr:=PathConv(strpas(p))+#0;
  591. { close first if opened }
  592. if ((flags and $10000)=0) then begin
  593. case filerec(f).mode of
  594. fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
  595. fmclosed : ;
  596. else begin
  597. inoutres:=102; {not assigned}
  598. exit;
  599. end;
  600. end;
  601. end;
  602. { reset file handle }
  603. filerec(f).handle:=UnusedHandle;
  604. { convert filemode to filerec modes }
  605. { READ/WRITE on existing file }
  606. { RESET/APPEND }
  607. openflags := 1005;
  608. case (flags and 3) of
  609. 0 : filerec(f).mode:=fminput;
  610. 1 : filerec(f).mode:=fmoutput;
  611. 2 : filerec(f).mode:=fminout;
  612. end;
  613. { rewrite (create a new file) }
  614. if (flags and $1000)<>0 then openflags := 1006;
  615. { empty name is special }
  616. if p[0]=#0 then begin
  617. case filerec(f).mode of
  618. fminput :
  619. filerec(f).handle:=StdInputHandle;
  620. fmappend,
  621. fmoutput : begin
  622. filerec(f).handle:=StdOutputHandle;
  623. filerec(f).mode:=fmoutput; {fool fmappend}
  624. end;
  625. end;
  626. exit;
  627. end;
  628. handle:=Open(@tmpStr,openflags);
  629. if handle=0 then begin
  630. dosError2InOut(IoErr);
  631. end else begin
  632. AddToList(MOS_fileList,handle);
  633. filerec(f).handle:=handle;
  634. end;
  635. { append mode }
  636. if ((Flags and $100)<>0) and
  637. (FileRec(F).Handle<>UnusedHandle) then begin
  638. do_seekend(filerec(f).handle);
  639. filerec(f).mode:=fmoutput; {fool fmappend}
  640. end;
  641. end;
  642. function do_isdevice(handle:longint):boolean;
  643. begin
  644. if (handle=StdOutputHandle) or (handle=StdInputHandle) or
  645. (handle=StdErrorHandle) then
  646. do_isdevice:=True
  647. else
  648. do_isdevice:=False;
  649. end;
  650. {*****************************************************************************
  651. UnTyped File Handling
  652. *****************************************************************************}
  653. {$i file.inc}
  654. {*****************************************************************************
  655. Typed File Handling
  656. *****************************************************************************}
  657. {$i typefile.inc}
  658. {*****************************************************************************
  659. Text File Handling
  660. *****************************************************************************}
  661. {$I text.inc}
  662. { MorphOS specific startup }
  663. procedure SysInitMorphOS;
  664. var self: PProcess;
  665. begin
  666. self:=PProcess(FindTask(nil));
  667. if self^.pr_CLI=0 then begin
  668. { if we're running from Ambient/Workbench, we catch its message }
  669. WaitPort(@self^.pr_MsgPort);
  670. MOS_ambMsg:=GetMsg(@self^.pr_MsgPort);
  671. end;
  672. MOS_DOSBase:=OpenLibrary('dos.library',50);
  673. if MOS_DOSBase=nil then Halt(1);
  674. MOS_UtilityBase:=OpenLibrary('utility.library',50);
  675. if MOS_UtilityBase=nil then Halt(1);
  676. { Creating the memory pool for growing heap }
  677. MOS_heapPool:=CreatePool(MEMF_FAST,growheapsize2,growheapsize1);
  678. if MOS_heapPool=nil then Halt(1);
  679. if MOS_ambMsg=nil then begin
  680. StdInputHandle:=dosInput;
  681. StdOutputHandle:=dosOutput;
  682. end else begin
  683. MOS_ConHandle:=Open(MOS_ConName,1005);
  684. if MOS_ConHandle<>0 then begin
  685. StdInputHandle:=MOS_ConHandle;
  686. StdOutputHandle:=MOS_ConHandle;
  687. end else
  688. Halt(1);
  689. end;
  690. end;
  691. procedure SysInitStdIO;
  692. begin
  693. OpenStdIO(Input,fmInput,StdInputHandle);
  694. OpenStdIO(Output,fmOutput,StdOutputHandle);
  695. OpenStdIO(StdOut,fmOutput,StdOutputHandle);
  696. { * MorphOS doesn't have a separate stderr, just like AmigaOS (???) * }
  697. StdErrorHandle:=StdOutputHandle;
  698. // OpenStdIO(StdErr,fmOutput,StdErrorHandle);
  699. // OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
  700. end;
  701. function GetProcessID: SizeUInt;
  702. begin
  703. GetProcessID := 1;
  704. {$WARNING Implementation of GetProcessID missing!}
  705. end;
  706. begin
  707. IsConsole := TRUE;
  708. IsLibrary := FALSE;
  709. StackLength := InitialStkLen;
  710. StackBottom := Sptr - StackLength;
  711. { OS specific startup }
  712. MOS_ambMsg:=nil;
  713. MOS_origDir:=0;
  714. MOS_fileList:=nil;
  715. envp:=nil;
  716. SysInitMorphOS;
  717. { Set up signals handlers }
  718. // InstallSignals;
  719. { Setup heap }
  720. InitHeap;
  721. SysInitExceptions;
  722. { Setup stdin, stdout and stderr }
  723. SysInitStdIO;
  724. { Reset IO Error }
  725. InOutRes:=0;
  726. { Arguments }
  727. GenerateArgs;
  728. (* This should be changed to a real value during *)
  729. (* thread driver initialization if appropriate. *)
  730. ThreadID := 1;
  731. {$ifdef HASVARIANT}
  732. initvariantmanager;
  733. {$endif HASVARIANT}
  734. end.
  735. {
  736. $Log$
  737. Revision 1.25 2004-12-07 09:55:46 karoly
  738. * previous change broke PathConv, fixed
  739. Revision 1.24 2004/12/06 20:09:55 karoly
  740. * added a public alias to PathConv for use in DOS unit
  741. Revision 1.23 2004/12/05 14:36:37 hajny
  742. + GetProcessID added
  743. Revision 1.22 2004/11/15 23:18:16 karoly
  744. * Reworked path handling to be less messy
  745. Revision 1.21 2004/11/04 09:32:31 peter
  746. ErrOutput added
  747. Revision 1.20 2004/10/25 15:38:59 peter
  748. * compiler defined HEAP and HEAPSIZE removed
  749. Revision 1.19 2004/09/03 19:26:15 olle
  750. + added maxExitCode to all System.pp
  751. * constrained error code to be below maxExitCode in RunError et. al.
  752. Revision 1.18 2004/08/09 00:12:40 karoly
  753. * changes to work with updated doslib includes
  754. Revision 1.17 2004/08/03 15:59:41 karoly
  755. * more cleanup & more includes
  756. Revision 1.16 2004/06/26 20:48:24 karoly
  757. * more cleanup + changes to use new includes
  758. Revision 1.15 2004/06/23 13:27:32 karoly
  759. * fixed system unit for the new heap manager
  760. Revision 1.14 2004/06/17 16:16:14 peter
  761. * New heapmanager that releases memory back to the OS, donated
  762. by Micha Nelissen
  763. Revision 1.13 2004/06/13 22:50:47 karoly
  764. * cleanup and changes to use new includes
  765. Revision 1.12 2004/06/06 23:31:13 karoly
  766. * fixed dos_UnLockDosList from being nonsense, and some cleanup
  767. Revision 1.11 2004/06/06 19:18:05 karoly
  768. + added support for paramstr(0)
  769. Revision 1.10 2004/06/05 19:49:19 karoly
  770. + added console I/O support when running from Ambient
  771. Revision 1.9 2004/05/12 23:18:54 karoly
  772. * fixed do_read and dos_Read from being nonsense
  773. Revision 1.8 2004/05/12 20:26:04 karoly
  774. + added syscalls and structures necessary for DOS unit
  775. Revision 1.7 2004/05/12 15:34:16 karoly
  776. * fixed startup code from endless wait when not started from Ambient
  777. Revision 1.6 2004/05/09 14:42:59 karoly
  778. * again, few more new things added
  779. Revision 1.5 2004/05/09 02:02:42 karoly
  780. * more things got implemented
  781. Revision 1.4 2004/05/02 02:06:57 karoly
  782. + most of file I/O calls implemented
  783. Revision 1.3 2004/05/01 15:09:47 karoly
  784. * first working system unit (very limited yet)
  785. Revision 1.2  2004/04/08 06:28:29  karoly
  786. * first steps to have a morphos system unit
  787. Revision 1.1 2004/02/13 07:19:53 karoly
  788. * quick hack from Linux system unit
  789. }