system.pp 25 KB

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