unix.pp 43 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2000 by Michael Van Canneyt,
  5. BSD parts (c) 2000 by Marco van de Voort
  6. members of the Free Pascal development team.
  7. See the file COPYING.FPC, included in this distribution,
  8. for details about the copyright.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY;without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12. **********************************************************************}
  13. Unit Unix;
  14. Interface
  15. Uses UnixUtil,BaseUnix;
  16. {// i ostypes.inc}
  17. { Get Types and Constants }
  18. {$i sysconst.inc}
  19. {$i systypes.inc}
  20. { Get System call numbers and error-numbers}
  21. {$i sysnr.inc}
  22. {$i errno.inc}
  23. {$I signal.inc}
  24. {$i ostypes.inc}
  25. var
  26. LinuxError : Longint;
  27. {********************
  28. Process
  29. ********************}
  30. const
  31. { For getting/setting priority }
  32. Prio_Process = 0;
  33. Prio_PGrp = 1;
  34. Prio_User = 2;
  35. {$ifdef Solaris}
  36. WNOHANG = $100;
  37. WUNTRACED = $4;
  38. {$ELSE}
  39. WNOHANG = $1;
  40. WUNTRACED = $2;
  41. __WCLONE = $80000000;
  42. {$ENDIF}
  43. {********************
  44. File
  45. ********************}
  46. Const
  47. P_IN = 1;
  48. P_OUT = 2;
  49. Const
  50. LOCK_SH = 1;
  51. LOCK_EX = 2;
  52. LOCK_UN = 8;
  53. LOCK_NB = 4;
  54. Type
  55. Tpipe = array[1..2] of longint;
  56. pglob = ^tglob;
  57. tglob = record
  58. name : pchar;
  59. next : pglob;
  60. end;
  61. const
  62. { For File control mechanism }
  63. F_GetFd = 1;
  64. F_SetFd = 2;
  65. F_GetFl = 3;
  66. F_SetFl = 4;
  67. {$ifdef Solaris}
  68. F_DupFd = 0;
  69. F_Dup2Fd = 9;
  70. F_GetOwn = 23;
  71. F_SetOwn = 24;
  72. F_GetLk = 14;
  73. F_SetLk = 6;
  74. F_SetLkW = 7;
  75. F_FreeSp = 11;
  76. {$else}
  77. F_GetLk = 5;
  78. F_SetLk = 6;
  79. F_SetLkW = 7;
  80. F_SetOwn = 8;
  81. F_GetOwn = 9;
  82. {$endif}
  83. {********************
  84. IOCtl(TermIOS)
  85. ********************}
  86. {Is too freebsd/Linux specific}
  87. {$I termios.inc}
  88. {******************************************************************************
  89. Procedure/Functions
  90. ******************************************************************************}
  91. {**************************
  92. Time/Date Handling
  93. ***************************}
  94. var
  95. tzdaylight : boolean;
  96. tzname : array[boolean] of pchar;
  97. { timezone support }
  98. procedure GetLocalTimezone(timer:longint;var leap_correct,leap_hit:longint);
  99. procedure GetLocalTimezone(timer:longint);
  100. procedure ReadTimezoneFile(fn:string);
  101. function GetTimezoneFile:string;
  102. Function GetEpochTime: longint;
  103. procedure GetTime(var hour,min,sec,msec,usec:word);
  104. procedure GetTime(var hour,min,sec,sec100:word);
  105. procedure GetTime(var hour,min,sec:word);
  106. Procedure GetDate(Var Year,Month,Day:Word);
  107. Procedure GetDateTime(Var Year,Month,Day,hour,minute,second:Word);
  108. function SetTime(Hour,Min,Sec:word) : Boolean;
  109. function SetDate(Year,Month,Day:Word) : Boolean;
  110. function SetDateTime(Year,Month,Day,hour,minute,second:Word) : Boolean;
  111. {**************************
  112. Process Handling
  113. ***************************}
  114. function CreateShellArgV(const prog:string):ppchar;
  115. function CreateShellArgV(const prog:Ansistring):ppchar;
  116. //Procedure Execve(Path: pathstr;args:ppchar;ep:ppchar);
  117. //Procedure Execve(Path: AnsiString;args:ppchar;ep:ppchar);
  118. //Procedure Execve(path: pchar;args:ppchar;ep:ppchar);
  119. Procedure Execv(const path:pathstr;args:ppchar);
  120. Procedure Execv(const path: AnsiString;args:ppchar);
  121. Procedure Execvp(Path: Pathstr;Args:ppchar;Ep:ppchar);
  122. Procedure Execvp(Path: AnsiString; Args:ppchar;Ep:ppchar);
  123. Procedure Execl(const Todo: String);
  124. Procedure Execl(const Todo: Ansistring);
  125. Procedure Execle(Todo: String;Ep:ppchar);
  126. Procedure Execle(Todo: AnsiString;Ep:ppchar);
  127. Procedure Execlp(Todo: string;Ep:ppchar);
  128. Procedure Execlp(Todo: Ansistring;Ep:ppchar);
  129. Function Shell(const Command:String):Longint;
  130. Function Shell(const Command:AnsiString):Longint;
  131. {Clone for FreeBSD is copied from the LinuxThread port, and rfork based}
  132. function Clone(func:TCloneFunc;sp:pointer;flags:longint;args:pointer):longint;
  133. Function WaitProcess(Pid:longint):Longint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated}
  134. Function WIFSTOPPED(Status: Integer): Boolean;
  135. Function W_EXITCODE(ReturnCode, Signal: Integer): Integer;
  136. Function W_STOPCODE(Signal: Integer): Integer;
  137. {**************************
  138. File Handling
  139. ***************************}
  140. Function fdFlush (fd : Longint) : Boolean;
  141. Function Flock (fd,mode : longint) : boolean;
  142. Function Flock (var T : text;mode : longint) : boolean;
  143. Function Flock (var F : File;mode : longint) : boolean;
  144. Function StatFS(Path:Pathstr;Var Info:tstatfs):Boolean;
  145. Function StatFS(Fd: Longint;Var Info:tstatfs):Boolean;
  146. Function SelectText(var T:Text;TimeOut :PTimeVal):Longint;
  147. Function SelectText(var T:Text;TimeOut :Longint):Longint;
  148. {**************************
  149. Directory Handling
  150. ***************************}
  151. procedure SeekDir(p:pdir;off:longint);
  152. function TellDir(p:pdir):longint;
  153. {**************************
  154. Pipe/Fifo/Stream
  155. ***************************}
  156. Function AssignPipe(var pipe_in,pipe_out:longint):boolean;
  157. Function AssignPipe(var pipe_in,pipe_out:text):boolean;
  158. Function AssignPipe(var pipe_in,pipe_out:file):boolean;
  159. Function PClose(Var F:text) : longint;
  160. Function PClose(Var F:file) : longint;
  161. Procedure POpen(var F:text;const Prog:String;rw:char);
  162. Procedure POpen(var F:file;const Prog:String;rw:char);
  163. function AssignStream(Var StreamIn,Streamout:text;Const Prog:String) : longint;
  164. function AssignStream(var StreamIn, StreamOut, StreamErr: Text; const prog: String): LongInt;
  165. {$ifndef BSD}
  166. Function GetDomainName:String;
  167. Function GetHostName:String;
  168. {$endif}
  169. {**************************
  170. IOCtl/Termios Functions
  171. ***************************}
  172. Function TCGetAttr(fd:longint;var tios:TermIOS):boolean;
  173. Function TCSetAttr(fd:longint;OptAct:longint;const tios:TermIOS):boolean;
  174. Procedure CFSetISpeed(var tios:TermIOS;speed:Cardinal);
  175. Procedure CFSetOSpeed(var tios:TermIOS;speed:Cardinal);
  176. Procedure CFMakeRaw(var tios:TermIOS);
  177. Function TCSendBreak(fd,duration:longint):boolean;
  178. Function TCSetPGrp(fd,id:longint):boolean;
  179. Function TCGetPGrp(fd:longint;var id:longint):boolean;
  180. Function TCFlush(fd,qsel:longint):boolean;
  181. Function TCDrain(fd:longint):boolean;
  182. Function TCFlow(fd,act:longint):boolean;
  183. Function IsATTY(Handle:Longint):Boolean;
  184. Function IsATTY(var f:text):Boolean;
  185. function TTYname(Handle:Longint):string;
  186. function TTYname(var F:Text):string;
  187. {**************************
  188. Memory functions
  189. ***************************}
  190. const
  191. PROT_READ = $1; { page can be read }
  192. PROT_WRITE = $2; { page can be written }
  193. PROT_EXEC = $4; { page can be executed }
  194. PROT_NONE = $0; { page can not be accessed }
  195. MAP_SHARED = $1; { Share changes }
  196. // MAP_PRIVATE = $2; { Changes are private }
  197. MAP_TYPE = $f; { Mask for type of mapping }
  198. MAP_FIXED = $10; { Interpret addr exactly }
  199. // MAP_ANONYMOUS = $20; { don't use a file }
  200. MAP_GROWSDOWN = $100; { stack-like segment }
  201. MAP_DENYWRITE = $800; { ETXTBSY }
  202. MAP_EXECUTABLE = $1000; { mark it as an executable }
  203. MAP_LOCKED = $2000; { pages are locked }
  204. MAP_NORESERVE = $4000; { don't check for reservations }
  205. {**************************
  206. Utility functions
  207. ***************************}
  208. Function Octal(l:longint):longint;
  209. Function FExpand(Const Path: PathStr):PathStr;
  210. Function FSearch(const path:pathstr;dirlist:string):pathstr;
  211. Function Glob(Const path:pathstr):pglob;
  212. Procedure Globfree(var p:pglob);
  213. {Filedescriptorsets}
  214. {Stat.Mode Types}
  215. procedure SigRaise(sig:integer);
  216. {******************************************************************************
  217. Implementation
  218. ******************************************************************************}
  219. {$i unxsysch.inc}
  220. Implementation
  221. Uses Strings;
  222. {$i syscallh.inc}
  223. {$i ossysch.inc}
  224. {$i unxsysc.inc}
  225. { Get the definitions of textrec and filerec }
  226. {$i textrec.inc}
  227. {$i filerec.inc}
  228. { Raw System calls are in Syscalls.inc}
  229. {$i syscalls.inc}
  230. {$i unixsysc.inc} {Syscalls only used in unit Unix/Linux}
  231. Function getenv(name:string):Pchar; external name 'FPC_SYSC_FPGETENV';
  232. {******************************************************************************
  233. Process related calls
  234. ******************************************************************************}
  235. { Most calls of WaitPID do not handle the result correctly, this funktion treats errors more correctly }
  236. Function WaitProcess(Pid:longint):Longint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated}
  237. var r,s : LongInt;
  238. begin
  239. repeat
  240. s:=$7F00;
  241. r:=fpWaitPid(Pid,@s,0);
  242. until (r<>-1) or (LinuxError<>ESysEINTR);
  243. if (r=-1) or (r=0) then // 0 is not a valid return and should never occur (it means status invalid when using WNOHANG)
  244. WaitProcess:=-1 // return -1 to indicate an error
  245. else
  246. begin
  247. {$ifndef Solaris}
  248. { at least correct for Linux and Darwin (JM) }
  249. if (s and $7F)=0 then // Only this is a valid returncode
  250. {$else}
  251. if (s and $FF)=0 then // Only this is a valid returncode
  252. {$endif}
  253. WaitProcess:=s shr 8
  254. else if (s>0) then // Until now there is not use of the highest bit , but check this for the future
  255. WaitProcess:=-s // normal case
  256. else
  257. WaitProcess:=s; // s<0 should not occur, but wie return also a negativ value
  258. end;
  259. end;
  260. function InternalCreateShellArgV(cmd:pChar; len:longint):ppchar;
  261. {
  262. Create an argv which executes a command in a shell using /bin/sh -c
  263. }
  264. const Shell = '/bin/sh'#0'-c'#0;
  265. var
  266. pp,p : ppchar;
  267. // temp : string; !! Never pass a local var back!!
  268. begin
  269. getmem(pp,4*4);
  270. p:=pp;
  271. p^:=@Shell[1];
  272. inc(p);
  273. p^:=@Shell[9];
  274. inc(p);
  275. getmem(p^,len+1);
  276. move(cmd^,p^^,len);
  277. pchar(p^)[len]:=#0;
  278. inc(p);
  279. p^:=Nil;
  280. InternalCreateShellArgV:=pp;
  281. end;
  282. function CreateShellArgV(const prog:string):ppchar;
  283. begin
  284. CreateShellArgV:=InternalCreateShellArgV(@prog[1],length(prog));
  285. end;
  286. function CreateShellArgV(const prog:Ansistring):ppchar;
  287. {
  288. Create an argv which executes a command in a shell using /bin/sh -c
  289. using a AnsiString;
  290. }
  291. begin
  292. CreateShellArgV:=InternalCreateShellArgV(@prog[1],length(prog)); // if ppc works like delphi this also work when @prog[1] is invalid (len=0)
  293. end;
  294. procedure FreeShellArgV(p:ppchar);
  295. begin
  296. if (p<>nil) then begin
  297. freemem(p[2]);
  298. freemem(p);
  299. end;
  300. end;
  301. Procedure Execv(const path: AnsiString;args:ppchar);
  302. {
  303. Overloaded ansistring version.
  304. }
  305. begin
  306. fpExecVe(Path,Args,envp)
  307. end;
  308. Procedure Execvp(Path: AnsiString; Args:ppchar;Ep:ppchar);
  309. {
  310. Overloaded ansistring version
  311. }
  312. var
  313. thepath : Ansistring;
  314. begin
  315. if path[1]<>'/' then
  316. begin
  317. Thepath:=strpas(fpgetenv('PATH'));
  318. if thepath='' then
  319. thepath:='.';
  320. Path:=FSearch(path,thepath)
  321. end
  322. else
  323. Path:='';
  324. if Path='' then
  325. linuxerror:=ESysEnoent
  326. else
  327. fpExecve(Path,args,ep);{On error linuxerror will get set there}
  328. end;
  329. Procedure Execv(const path:pathstr;args:ppchar);
  330. {
  331. Replaces the current program by the program specified in path,
  332. arguments in args are passed to Execve.
  333. the current environment is passed on.
  334. }
  335. begin
  336. fpExecve(path,args,envp); {On error linuxerror will get set there}
  337. end;
  338. Procedure Execvp(Path:Pathstr;Args:ppchar;Ep:ppchar);
  339. {
  340. This does the same as Execve, only it searches the PATH environment
  341. for the place of the Executable, except when Path starts with a slash.
  342. if the PATH environment variable is unavailable, the path is set to '.'
  343. }
  344. var
  345. thepath : string;
  346. begin
  347. if path[1]<>'/' then
  348. begin
  349. Thepath:=strpas(fpgetenv('PATH'));
  350. if thepath='' then
  351. thepath:='.';
  352. Path:=FSearch(path,thepath)
  353. end
  354. else
  355. Path:='';
  356. if Path='' then
  357. linuxerror:=ESysEnoent
  358. else
  359. fpExecve(Path,args,ep);{On error linuxerror will get set there}
  360. end;
  361. Procedure Execle(Todo:string;Ep:ppchar);
  362. {
  363. This procedure takes the string 'Todo', parses it for command and
  364. command options, and Executes the command with the given options.
  365. The string 'Todo' shoud be of the form 'command options', options
  366. separated by commas.
  367. the PATH environment is not searched for 'command'.
  368. The specified environment(in 'ep') is passed on to command
  369. }
  370. var
  371. p : ppchar;
  372. begin
  373. p:=StringToPPChar(ToDo);
  374. if (p=nil) or (p^=nil) then
  375. exit;
  376. fpExecVE(p^,p,EP);
  377. end;
  378. Procedure Execle(Todo:AnsiString;Ep:ppchar);
  379. {
  380. This procedure takes the string 'Todo', parses it for command and
  381. command options, and Executes the command with the given options.
  382. The string 'Todo' shoud be of the form 'command options', options
  383. separated by commas.
  384. the PATH environment is not searched for 'command'.
  385. The specified environment(in 'ep') is passed on to command
  386. }
  387. var
  388. p : ppchar;
  389. begin
  390. p:=StringToPPChar(ToDo);
  391. if (p=nil) or (p^=nil) then
  392. exit;
  393. fpExecVE(p^,p,EP);
  394. end;
  395. Procedure Execl(const Todo:string);
  396. {
  397. This procedure takes the string 'Todo', parses it for command and
  398. command options, and Executes the command with the given options.
  399. The string 'Todo' shoud be of the form 'command options', options
  400. separated by commas.
  401. the PATH environment is not searched for 'command'.
  402. The current environment is passed on to command
  403. }
  404. begin
  405. ExecLE(ToDo,EnvP);
  406. end;
  407. Procedure Execlp(Todo:string;Ep:ppchar);
  408. {
  409. This procedure takes the string 'Todo', parses it for command and
  410. command options, and Executes the command with the given options.
  411. The string 'Todo' shoud be of the form 'command options', options
  412. separated by commas.
  413. the PATH environment is searched for 'command'.
  414. The specified environment (in 'ep') is passed on to command
  415. }
  416. var
  417. p : ppchar;
  418. begin
  419. p:=StringToPPchar(todo);
  420. if (p=nil) or (p^=nil) then
  421. exit;
  422. ExecVP(StrPas(p^),p,EP);
  423. end;
  424. Procedure Execlp(Todo: Ansistring;Ep:ppchar);
  425. {
  426. Overloaded ansistring version.
  427. }
  428. var
  429. p : ppchar;
  430. begin
  431. p:=StringToPPchar(todo);
  432. if (p=nil) or (p^=nil) then
  433. exit;
  434. ExecVP(StrPas(p^),p,EP);
  435. end;
  436. Function Shell(const Command:String):Longint;
  437. {
  438. Executes the shell, and passes it the string Command. (Through /bin/sh -c)
  439. The current environment is passed to the shell.
  440. It waits for the shell to exit, and returns its exit status.
  441. If the Exec call failed exit status 127 is reported.
  442. }
  443. { Changed the structure:
  444. - the previous version returns an undefinied value if fork fails
  445. - it returns the status of Waitpid instead of the Process returnvalue (see the doc to Shell)
  446. - it uses exit(127) not ExitProc (The Result in pp386: going on Compiling in 2 processes!)
  447. - ShellArgs are now released
  448. - The Old CreateShellArg gives back pointers to a local var
  449. }
  450. var
  451. p : ppchar;
  452. pid : longint;
  453. begin
  454. p:=CreateShellArgv(command);
  455. pid:=fpfork;
  456. if pid=0 then // We are in the Child
  457. begin
  458. {This is the child.}
  459. fpExecve(p^,p,envp);
  460. fpExit(127); // was Exit(127)
  461. end
  462. else if (pid<>-1) then // Successfull started
  463. Shell:=WaitProcess(pid) {Linuxerror is set there}
  464. else // no success
  465. Shell:=-1; // indicate an error
  466. FreeShellArgV(p);
  467. end;
  468. Function Shell(const Command:AnsiString):Longint;
  469. {
  470. AnsiString version of Shell
  471. }
  472. var
  473. p : ppchar;
  474. pid : longint;
  475. begin { Changes as above }
  476. p:=CreateShellArgv(command);
  477. pid:=fpfork;
  478. if pid=0 then // We are in the Child
  479. begin
  480. fpExecve(p^,p,envp);
  481. fpExit(127); // was exit(127)!! We must exit the Process, not the function
  482. end
  483. else if (pid<>-1) then // Successfull started
  484. Shell:=WaitProcess(pid) {Linuxerror is set there}
  485. else // no success
  486. Shell:=-1;
  487. FreeShellArgV(p);
  488. end;
  489. Function WIFSTOPPED(Status: Integer): Boolean;
  490. begin
  491. WIFSTOPPED:=((Status and $FF)=$7F);
  492. end;
  493. Function W_EXITCODE(ReturnCode, Signal: Integer): Integer;
  494. begin
  495. W_EXITCODE:=(ReturnCode shl 8) or Signal;
  496. end;
  497. Function W_STOPCODE(Signal: Integer): Integer;
  498. begin
  499. W_STOPCODE:=(Signal shl 8) or $7F;
  500. end;
  501. {******************************************************************************
  502. Date and Time related calls
  503. ******************************************************************************}
  504. Function GetEpochTime: longint;
  505. {
  506. Get the number of seconds since 00:00, January 1 1970, GMT
  507. the time NOT corrected any way
  508. }
  509. begin
  510. GetEpochTime:=fptime;
  511. end;
  512. procedure GetTime(var hour,min,sec,msec,usec:word);
  513. {
  514. Gets the current time, adjusted to local time
  515. }
  516. var
  517. year,day,month:Word;
  518. tz:timeval;
  519. begin
  520. fpgettimeofday(@tz,nil);
  521. EpochToLocal(tz.tv_sec,year,month,day,hour,min,sec);
  522. msec:=tz.tv_usec div 1000;
  523. usec:=tz.tv_usec mod 1000;
  524. end;
  525. procedure GetTime(var hour,min,sec,sec100:word);
  526. {
  527. Gets the current time, adjusted to local time
  528. }
  529. var
  530. usec : word;
  531. begin
  532. gettime(hour,min,sec,sec100,usec);
  533. sec100:=sec100 div 10;
  534. end;
  535. Procedure GetTime(Var Hour,Min,Sec:Word);
  536. {
  537. Gets the current time, adjusted to local time
  538. }
  539. var
  540. msec,usec : Word;
  541. Begin
  542. gettime(hour,min,sec,msec,usec);
  543. End;
  544. Procedure GetDate(Var Year,Month,Day:Word);
  545. {
  546. Gets the current date, adjusted to local time
  547. }
  548. var
  549. hour,minute,second : word;
  550. Begin
  551. EpochToLocal(fptime,year,month,day,hour,minute,second);
  552. End;
  553. Procedure GetDateTime(Var Year,Month,Day,hour,minute,second:Word);
  554. {
  555. Gets the current date, adjusted to local time
  556. }
  557. Begin
  558. EpochToLocal(fptime,year,month,day,hour,minute,second);
  559. End;
  560. {$ifndef BSD}
  561. {$ifdef linux}
  562. Function stime (t : longint) : Boolean;
  563. var
  564. sr : Syscallregs;
  565. begin
  566. sr.reg2:=longint(@t);
  567. SysCall(Syscall_nr_stime,sr);
  568. linuxerror:=fpgeterrno;;
  569. stime:=linuxerror=0;
  570. end;
  571. {$endif}
  572. {$endif}
  573. {$ifdef BSD}
  574. Function stime (t : longint) : Boolean;
  575. begin
  576. end;
  577. {$endif}
  578. Function SetTime(Hour,Min,Sec:word) : boolean;
  579. var
  580. Year, Month, Day : Word;
  581. begin
  582. GetDate (Year, Month, Day);
  583. SetTime:=stime ( LocalToEpoch ( Year, Month, Day, Hour, Min, Sec ) );
  584. end;
  585. Function SetDate(Year,Month,Day:Word) : boolean;
  586. var
  587. Hour, Minute, Second, Sec100 : Word;
  588. begin
  589. GetTime ( Hour, Minute, Second, Sec100 );
  590. SetDate:=stime ( LocalToEpoch ( Year, Month, Day, Hour, Minute, Second ) );
  591. end;
  592. Function SetDateTime(Year,Month,Day,hour,minute,second:Word) : Boolean;
  593. begin
  594. SetDateTime:=stime ( LocalToEpoch ( Year, Month, Day, Hour, Minute, Second ) );
  595. end;
  596. { Include timezone handling routines which use /usr/share/timezone info }
  597. {$i timezone.inc}
  598. {******************************************************************************
  599. FileSystem calls
  600. ******************************************************************************}
  601. Procedure Execl(const Todo:Ansistring);
  602. {
  603. Overloaded AnsiString Version of ExecL.
  604. }
  605. begin
  606. ExecLE(ToDo,EnvP);
  607. end;
  608. Function Flock (var T : text;mode : longint) : boolean;
  609. begin
  610. Flock:=Flock(TextRec(T).Handle,mode);
  611. end;
  612. Function Flock (var F : File;mode : longint) : boolean;
  613. begin
  614. Flock:=Flock(FileRec(F).Handle,mode);
  615. end;
  616. Function SelectText(var T:Text;TimeOut :PTimeval):Longint;
  617. Var
  618. F:TfdSet;
  619. begin
  620. if textrec(t).mode=fmclosed then
  621. begin
  622. LinuxError:=ESysEBADF;
  623. exit(-1);
  624. end;
  625. FpFD_ZERO(f);
  626. fpFD_SET(textrec(T).handle,f);
  627. if textrec(T).mode=fminput then
  628. SelectText:=fpselect(textrec(T).handle+1,@f,nil,nil,TimeOut)
  629. else
  630. SelectText:=fpselect(textrec(T).handle+1,nil,@f,nil,TimeOut);
  631. end;
  632. Function SelectText(var T:Text;TimeOut :Longint):Longint;
  633. var
  634. p : PTimeVal;
  635. tv : TimeVal;
  636. begin
  637. if TimeOut=-1 then
  638. p:=nil
  639. else
  640. begin
  641. tv.tv_Sec:=Timeout div 1000;
  642. tv.tv_Usec:=(Timeout mod 1000)*1000;
  643. p:=@tv;
  644. end;
  645. SelectText:=SelectText(T,p);
  646. end;
  647. {******************************************************************************
  648. Directory
  649. ******************************************************************************}
  650. procedure SeekDir(p:pdir;off:longint);
  651. begin
  652. if p=nil then
  653. begin
  654. fpseterrno(ESysEBADF);
  655. exit;
  656. end;
  657. {$ifndef bsd}
  658. p^.dd_nextoff:=fplseek(p^.dd_fd,off,seek_set);
  659. {$endif}
  660. p^.dd_size:=0;
  661. p^.dd_loc:=0;
  662. end;
  663. function TellDir(p:pdir):longint;
  664. begin
  665. if p=nil then
  666. begin
  667. fpseterrno(ESysEBADF);
  668. telldir:=-1;
  669. exit;
  670. end;
  671. telldir:=fplseek(p^.dd_fd,0,seek_cur)
  672. { We could try to use the nextoff field here, but on my 1.2.13
  673. kernel, this gives nothing... This may have to do with
  674. the readdir implementation of libc... I also didn't find any trace of
  675. the field in the kernel code itself, So I suspect it is an artifact of libc.
  676. Michael. }
  677. end;
  678. {******************************************************************************
  679. Pipes/Fifo
  680. ******************************************************************************}
  681. Procedure OpenPipe(var F:Text);
  682. begin
  683. case textrec(f).mode of
  684. fmoutput :
  685. if textrec(f).userdata[1]<>P_OUT then
  686. textrec(f).mode:=fmclosed;
  687. fminput :
  688. if textrec(f).userdata[1]<>P_IN then
  689. textrec(f).mode:=fmclosed;
  690. else
  691. textrec(f).mode:=fmclosed;
  692. end;
  693. end;
  694. Procedure IOPipe(var F:text);
  695. begin
  696. case textrec(f).mode of
  697. fmoutput :
  698. begin
  699. { first check if we need something to write, else we may
  700. get a SigPipe when Close() is called (PFV) }
  701. if textrec(f).bufpos>0 then
  702. fpwrite(textrec(f).handle,pchar(textrec(f).bufptr),textrec(f).bufpos);
  703. end;
  704. fminput :
  705. textrec(f).bufend:=fpread(textrec(f).handle,pchar(textrec(f).bufptr),textrec(f).bufsize);
  706. end;
  707. textrec(f).bufpos:=0;
  708. end;
  709. Procedure FlushPipe(var F:Text);
  710. begin
  711. if (textrec(f).mode=fmoutput) and (textrec(f).bufpos<>0) then
  712. IOPipe(f);
  713. textrec(f).bufpos:=0;
  714. end;
  715. Procedure ClosePipe(var F:text);
  716. begin
  717. textrec(f).mode:=fmclosed;
  718. fpclose(textrec(f).handle);
  719. end;
  720. Function AssignPipe(var pipe_in,pipe_out:text):boolean;
  721. {
  722. Sets up a pair of file variables, which act as a pipe. The first one can
  723. be read from, the second one can be written to.
  724. If the operation was unsuccesful, linuxerror is set.
  725. }
  726. var
  727. f_in,f_out : longint;
  728. begin
  729. if not AssignPipe(f_in,f_out) then
  730. begin
  731. AssignPipe:=false;
  732. exit;
  733. end;
  734. { Set up input }
  735. Assign(Pipe_in,'');
  736. Textrec(Pipe_in).Handle:=f_in;
  737. Textrec(Pipe_in).Mode:=fmInput;
  738. Textrec(Pipe_in).userdata[1]:=P_IN;
  739. TextRec(Pipe_in).OpenFunc:=@OpenPipe;
  740. TextRec(Pipe_in).InOutFunc:=@IOPipe;
  741. TextRec(Pipe_in).FlushFunc:=@FlushPipe;
  742. TextRec(Pipe_in).CloseFunc:=@ClosePipe;
  743. { Set up output }
  744. Assign(Pipe_out,'');
  745. Textrec(Pipe_out).Handle:=f_out;
  746. Textrec(Pipe_out).Mode:=fmOutput;
  747. Textrec(Pipe_out).userdata[1]:=P_OUT;
  748. TextRec(Pipe_out).OpenFunc:=@OpenPipe;
  749. TextRec(Pipe_out).InOutFunc:=@IOPipe;
  750. TextRec(Pipe_out).FlushFunc:=@FlushPipe;
  751. TextRec(Pipe_out).CloseFunc:=@ClosePipe;
  752. AssignPipe:=true;
  753. end;
  754. Function AssignPipe(var pipe_in,pipe_out:file):boolean;
  755. {
  756. Sets up a pair of file variables, which act as a pipe. The first one can
  757. be read from, the second one can be written to.
  758. If the operation was unsuccesful, linuxerror is set.
  759. }
  760. var
  761. f_in,f_out : longint;
  762. begin
  763. if not AssignPipe(f_in,f_out) then
  764. begin
  765. AssignPipe:=false;
  766. exit;
  767. end;
  768. { Set up input }
  769. Assign(Pipe_in,'');
  770. Filerec(Pipe_in).Handle:=f_in;
  771. Filerec(Pipe_in).Mode:=fmInput;
  772. Filerec(Pipe_in).recsize:=1;
  773. Filerec(Pipe_in).userdata[1]:=P_IN;
  774. { Set up output }
  775. Assign(Pipe_out,'');
  776. Filerec(Pipe_out).Handle:=f_out;
  777. Filerec(Pipe_out).Mode:=fmoutput;
  778. Filerec(Pipe_out).recsize:=1;
  779. Filerec(Pipe_out).userdata[1]:=P_OUT;
  780. AssignPipe:=true;
  781. end;
  782. Procedure PCloseText(Var F:text);
  783. {
  784. May not use @PClose due overloading
  785. }
  786. begin
  787. PClose(f);
  788. end;
  789. Procedure POpen(var F:text;const Prog:String;rw:char);
  790. {
  791. Starts the program in 'Prog' and makes it's input or out put the
  792. other end of a pipe. If rw is 'w' or 'W', then whatever is written to
  793. F, will be read from stdin by the program in 'Prog'. The inverse is true
  794. for 'r' or 'R' : whatever the program in 'Prog' writes to stdout, can be
  795. read from 'f'.
  796. }
  797. var
  798. pipi,
  799. pipo : text;
  800. pid : longint;
  801. pl : ^longint;
  802. pp : ppchar;
  803. begin
  804. LinuxError:=0;
  805. rw:=upcase(rw);
  806. if not (rw in ['R','W']) then
  807. begin
  808. LinuxError:=ESysEnoent;
  809. exit;
  810. end;
  811. AssignPipe(pipi,pipo);
  812. if Linuxerror<>0 then
  813. exit;
  814. pid:=fpfork;
  815. if linuxerror<>0 then
  816. begin
  817. close(pipi);
  818. close(pipo);
  819. exit;
  820. end;
  821. if pid=0 then
  822. begin
  823. { We're in the child }
  824. if rw='W' then
  825. begin
  826. close(pipo);
  827. fpdup2(pipi,input);
  828. close(pipi);
  829. if linuxerror<>0 then
  830. halt(127);
  831. end
  832. else
  833. begin
  834. close(pipi);
  835. fpdup2(pipo,output);
  836. close(pipo);
  837. if linuxerror<>0 then
  838. halt(127);
  839. end;
  840. pp:=createshellargv(prog);
  841. fpExecve(pp^,pp,envp);
  842. halt(127);
  843. end
  844. else
  845. begin
  846. { We're in the parent }
  847. if rw='W' then
  848. begin
  849. close(pipi);
  850. f:=pipo;
  851. textrec(f).bufptr:=@textrec(f).buffer;
  852. end
  853. else
  854. begin
  855. close(pipo);
  856. f:=pipi;
  857. textrec(f).bufptr:=@textrec(f).buffer;
  858. end;
  859. {Save the process ID - needed when closing }
  860. pl:=@(textrec(f).userdata[2]);
  861. pl^:=pid;
  862. textrec(f).closefunc:=@PCloseText;
  863. end;
  864. end;
  865. Procedure POpen(var F:file;const Prog:String;rw:char);
  866. {
  867. Starts the program in 'Prog' and makes it's input or out put the
  868. other end of a pipe. If rw is 'w' or 'W', then whatever is written to
  869. F, will be read from stdin by the program in 'Prog'. The inverse is true
  870. for 'r' or 'R' : whatever the program in 'Prog' writes to stdout, can be
  871. read from 'f'.
  872. }
  873. var
  874. pipi,
  875. pipo : file;
  876. pid : longint;
  877. pl : ^longint;
  878. p,pp : ppchar;
  879. temp : string[255];
  880. begin
  881. LinuxError:=0;
  882. rw:=upcase(rw);
  883. if not (rw in ['R','W']) then
  884. begin
  885. LinuxError:=ESysEnoent;
  886. exit;
  887. end;
  888. AssignPipe(pipi,pipo);
  889. if Linuxerror<>0 then
  890. exit;
  891. pid:=fpfork;
  892. if linuxerror<>0 then
  893. begin
  894. close(pipi);
  895. close(pipo);
  896. exit;
  897. end;
  898. if pid=0 then
  899. begin
  900. { We're in the child }
  901. if rw='W' then
  902. begin
  903. close(pipo);
  904. fpdup2(filerec(pipi).handle,stdinputhandle);
  905. close(pipi);
  906. if linuxerror<>0 then
  907. halt(127);
  908. end
  909. else
  910. begin
  911. close(pipi);
  912. fpdup2(filerec(pipo).handle,stdoutputhandle);
  913. close(pipo);
  914. if linuxerror<>0 then
  915. halt(127);
  916. end;
  917. getmem(pp,sizeof(pchar)*4);
  918. temp:='/bin/sh'#0'-c'#0+prog+#0;
  919. p:=pp;
  920. p^:=@temp[1];
  921. inc(p);
  922. p^:=@temp[9];
  923. inc(p);
  924. p^:=@temp[12];
  925. inc(p);
  926. p^:=Nil;
  927. fpExecve(ansistring('/bin/sh'),pp,envp);
  928. halt(127);
  929. end
  930. else
  931. begin
  932. { We're in the parent }
  933. if rw='W' then
  934. begin
  935. close(pipi);
  936. f:=pipo;
  937. end
  938. else
  939. begin
  940. close(pipo);
  941. f:=pipi;
  942. end;
  943. {Save the process ID - needed when closing }
  944. pl:=@(filerec(f).userdata[2]);
  945. pl^:=pid;
  946. end;
  947. end;
  948. Function AssignStream(Var StreamIn,Streamout:text;Const Prog:String) : longint;
  949. {
  950. Starts the program in 'Prog' and makes its input and output the
  951. other end of two pipes, which are the stdin and stdout of a program
  952. specified in 'Prog'.
  953. streamout can be used to write to the program, streamin can be used to read
  954. the output of the program. See the following diagram :
  955. Parent Child
  956. STreamout --> Input
  957. Streamin <-- Output
  958. Return value is the process ID of the process being spawned, or -1 in case of failure.
  959. }
  960. var
  961. pipi,
  962. pipo : text;
  963. pid : longint;
  964. pl : ^Longint;
  965. begin
  966. LinuxError:=0;
  967. AssignStream:=-1;
  968. AssignPipe(streamin,pipo);
  969. if Linuxerror<>0 then
  970. exit;
  971. AssignPipe(pipi,streamout);
  972. if Linuxerror<>0 then
  973. exit;
  974. pid:=fpfork;
  975. if linuxerror<>0 then
  976. begin
  977. close(pipi);
  978. close(pipo);
  979. close (streamin);
  980. close (streamout);
  981. exit;
  982. end;
  983. if pid=0 then
  984. begin
  985. { We're in the child }
  986. { Close what we don't need }
  987. close(streamout);
  988. close(streamin);
  989. fpdup2(pipi,input);
  990. if linuxerror<>0 then
  991. halt(127);
  992. close(pipi);
  993. fpdup2(pipo,output);
  994. if linuxerror<>0 then
  995. halt (127);
  996. close(pipo);
  997. Execl(Prog);
  998. halt(127);
  999. end
  1000. else
  1001. begin
  1002. { we're in the parent}
  1003. close(pipo);
  1004. close(pipi);
  1005. {Save the process ID - needed when closing }
  1006. pl:=@(textrec(StreamIn).userdata[2]);
  1007. pl^:=pid;
  1008. textrec(StreamIn).closefunc:=@PCloseText;
  1009. {Save the process ID - needed when closing }
  1010. pl:=@(textrec(StreamOut).userdata[2]);
  1011. pl^:=pid;
  1012. textrec(StreamOut).closefunc:=@PCloseText;
  1013. AssignStream:=Pid;
  1014. end;
  1015. end;
  1016. function AssignStream(var StreamIn, StreamOut, StreamErr: Text; const prog: String): LongInt;
  1017. {
  1018. Starts the program in 'prog' and makes its input, output and error output the
  1019. other end of three pipes, which are the stdin, stdout and stderr of a program
  1020. specified in 'prog'.
  1021. StreamOut can be used to write to the program, StreamIn can be used to read
  1022. the output of the program, StreamErr reads the error output of the program.
  1023. See the following diagram :
  1024. Parent Child
  1025. StreamOut --> StdIn (input)
  1026. StreamIn <-- StdOut (output)
  1027. StreamErr <-- StdErr (error output)
  1028. }
  1029. var
  1030. PipeIn, PipeOut, PipeErr: text;
  1031. pid: LongInt;
  1032. pl: ^LongInt;
  1033. begin
  1034. LinuxError := 0;
  1035. AssignStream := -1;
  1036. // Assign pipes
  1037. AssignPipe(StreamIn, PipeOut);
  1038. if LinuxError <> 0 then exit;
  1039. AssignPipe(StreamErr, PipeErr);
  1040. if LinuxError <> 0 then begin
  1041. Close(StreamIn);
  1042. Close(PipeOut);
  1043. exit;
  1044. end;
  1045. AssignPipe(PipeIn, StreamOut);
  1046. if LinuxError <> 0 then begin
  1047. Close(StreamIn);
  1048. Close(PipeOut);
  1049. Close(StreamErr);
  1050. Close(PipeErr);
  1051. exit;
  1052. end;
  1053. // Fork
  1054. pid := fpFork;
  1055. if LinuxError <> 0 then begin
  1056. Close(StreamIn);
  1057. Close(PipeOut);
  1058. Close(StreamErr);
  1059. Close(PipeErr);
  1060. Close(PipeIn);
  1061. Close(StreamOut);
  1062. exit;
  1063. end;
  1064. if pid = 0 then begin
  1065. // *** We are in the child ***
  1066. // Close what we don not need
  1067. Close(StreamOut);
  1068. Close(StreamIn);
  1069. Close(StreamErr);
  1070. // Connect pipes
  1071. fpdup2(PipeIn, Input);
  1072. if LinuxError <> 0 then Halt(127);
  1073. Close(PipeIn);
  1074. fpdup2(PipeOut, Output);
  1075. if LinuxError <> 0 then Halt(127);
  1076. Close(PipeOut);
  1077. fpdup2(PipeErr, StdErr);
  1078. if LinuxError <> 0 then Halt(127);
  1079. Close(PipeErr);
  1080. // Execute program
  1081. Execl(Prog);
  1082. Halt(127);
  1083. end else begin
  1084. // *** We are in the parent ***
  1085. Close(PipeErr);
  1086. Close(PipeOut);
  1087. Close(PipeIn);
  1088. // Save the process ID - needed when closing
  1089. pl := @(TextRec(StreamIn).userdata[2]);
  1090. pl^ := pid;
  1091. TextRec(StreamIn).closefunc := @PCloseText;
  1092. // Save the process ID - needed when closing
  1093. pl := @(TextRec(StreamOut).userdata[2]);
  1094. pl^ := pid;
  1095. TextRec(StreamOut).closefunc := @PCloseText;
  1096. // Save the process ID - needed when closing
  1097. pl := @(TextRec(StreamErr).userdata[2]);
  1098. pl^ := pid;
  1099. TextRec(StreamErr).closefunc := @PCloseText;
  1100. AssignStream := pid;
  1101. end;
  1102. end;
  1103. {******************************************************************************
  1104. General information calls
  1105. ******************************************************************************}
  1106. {$ifndef BSD}
  1107. Function GetDomainName:String; { linux only!}
  1108. // domainname is a glibc extension.
  1109. {
  1110. Get machines domain name. Returns empty string if not set.
  1111. }
  1112. Var
  1113. Sysn : utsname;
  1114. begin
  1115. fpUname(Sysn);
  1116. linuxerror:=fpgeterrno;;
  1117. If linuxerror<>0 then
  1118. getdomainname:=''
  1119. else
  1120. getdomainname:=strpas(@Sysn.domain[0]);
  1121. end;
  1122. {$endif}
  1123. Function GetHostName:String;
  1124. {
  1125. Get machines name. Returns empty string if not set.
  1126. }
  1127. Var
  1128. Sysn : utsname;
  1129. begin
  1130. fpuname(Sysn);
  1131. linuxerror:=fpgeterrno;;
  1132. If linuxerror<>0 then
  1133. gethostname:=''
  1134. else
  1135. gethostname:=strpas(@Sysn.nodename[0]);
  1136. end;
  1137. {******************************************************************************
  1138. Signal handling calls
  1139. ******************************************************************************}
  1140. procedure SigRaise(sig:integer);
  1141. begin
  1142. fpKill(fpGetPid,Sig);
  1143. end;
  1144. {******************************************************************************
  1145. IOCtl and Termios calls
  1146. ******************************************************************************}
  1147. Function TCGetAttr(fd:longint;var tios:TermIOS):boolean;
  1148. begin
  1149. {$ifndef BSD}
  1150. TCGetAttr:=fpIOCtl(fd,TCGETS,@tios)=0;
  1151. {$else}
  1152. TCGETAttr:=fpIoCtl(Fd,TIOCGETA,@tios)=0;
  1153. {$endif}
  1154. end;
  1155. Function TCSetAttr(fd:longint;OptAct:longint;const tios:TermIOS):boolean;
  1156. var
  1157. nr:longint;
  1158. begin
  1159. {$ifndef BSD}
  1160. case OptAct of
  1161. TCSANOW : nr:=TCSETS;
  1162. TCSADRAIN : nr:=TCSETSW;
  1163. TCSAFLUSH : nr:=TCSETSF;
  1164. {$else}
  1165. case OptAct of
  1166. TCSANOW : nr:=TIOCSETA;
  1167. TCSADRAIN : nr:=TIOCSETAW;
  1168. TCSAFLUSH : nr:=TIOCSETAF;
  1169. {$endif}
  1170. else
  1171. begin
  1172. fpsetErrNo(ESysEINVAL);
  1173. TCSetAttr:=false;
  1174. exit;
  1175. end;
  1176. end;
  1177. TCSetAttr:=fpIOCtl(fd,nr,@Tios)=0;
  1178. end;
  1179. Procedure CFSetISpeed(var tios:TermIOS;speed:Cardinal);
  1180. begin
  1181. {$ifndef BSD}
  1182. tios.c_cflag:=(tios.c_cflag and (not CBAUD)) or speed;
  1183. {$else}
  1184. tios.c_ispeed:=speed; {Probably the Bxxxx speed constants}
  1185. {$endif}
  1186. end;
  1187. Procedure CFSetOSpeed(var tios:TermIOS;speed:Cardinal);
  1188. begin
  1189. {$ifndef BSD}
  1190. CFSetISpeed(tios,speed);
  1191. {$else}
  1192. tios.c_ospeed:=speed;
  1193. {$endif}
  1194. end;
  1195. Procedure CFMakeRaw(var tios:TermIOS);
  1196. begin
  1197. {$ifndef BSD}
  1198. with tios do
  1199. begin
  1200. c_iflag:=c_iflag and (not (IGNBRK or BRKINT or PARMRK or ISTRIP or
  1201. INLCR or IGNCR or ICRNL or IXON));
  1202. c_oflag:=c_oflag and (not OPOST);
  1203. c_lflag:=c_lflag and (not (ECHO or ECHONL or ICANON or ISIG or IEXTEN));
  1204. c_cflag:=(c_cflag and (not (CSIZE or PARENB))) or CS8;
  1205. end;
  1206. {$else}
  1207. with tios do
  1208. begin
  1209. c_iflag:=c_iflag and (not (IMAXBEL or IXOFF or INPCK or BRKINT or
  1210. PARMRK or ISTRIP or INLCR or IGNCR or ICRNL or IXON or
  1211. IGNPAR));
  1212. c_iflag:=c_iflag OR IGNBRK;
  1213. c_oflag:=c_oflag and (not OPOST);
  1214. c_lflag:=c_lflag and (not (ECHO or ECHOE or ECHOK or ECHONL or ICANON or
  1215. ISIG or IEXTEN or NOFLSH or TOSTOP or PENDIN));
  1216. c_cflag:=(c_cflag and (not (CSIZE or PARENB))) or (CS8 OR cread);
  1217. c_cc[VMIN]:=1;
  1218. c_cc[VTIME]:=0;
  1219. end;
  1220. {$endif}
  1221. end;
  1222. Function TCSendBreak(fd,duration:longint):boolean;
  1223. begin
  1224. {$ifndef BSD}
  1225. TCSendBreak:=fpIOCtl(fd,TCSBRK,pointer(duration))=0;
  1226. {$else}
  1227. TCSendBreak:=fpIOCtl(fd,TIOCSBRK,0)=0;
  1228. {$endif}
  1229. end;
  1230. Function TCSetPGrp(fd,id:longint):boolean;
  1231. begin
  1232. TCSetPGrp:=fpIOCtl(fd,TIOCSPGRP,pointer(id))=0;
  1233. end;
  1234. Function TCGetPGrp(fd:longint;var id:longint):boolean;
  1235. begin
  1236. TCGetPGrp:=fpIOCtl(fd,TIOCGPGRP,@id)=0;
  1237. end;
  1238. Function TCDrain(fd:longint):boolean;
  1239. begin
  1240. {$ifndef BSD}
  1241. TCDrain:=fpIOCtl(fd,TCSBRK,pointer(1))=0;
  1242. {$else}
  1243. TCDrain:=fpIOCtl(fd,TIOCDRAIN,0)=0; {Should set timeout to 1 first?}
  1244. {$endif}
  1245. end;
  1246. Function TCFlow(fd,act:longint):boolean;
  1247. begin
  1248. {$ifndef BSD}
  1249. TCFlow:=fpIOCtl(fd,TCXONC,pointer(act))=0;
  1250. {$else}
  1251. case act OF
  1252. TCOOFF : TCFlow:=fpIoctl(fd,TIOCSTOP,0)=0;
  1253. TCOOn : TCFlow:=fpIOctl(Fd,TIOCStart,0)=0;
  1254. TCIOFF : {N/I}
  1255. end;
  1256. {$endif}
  1257. end;
  1258. Function TCFlush(fd,qsel:longint):boolean;
  1259. begin
  1260. {$ifndef BSD}
  1261. TCFlush:=fpIOCtl(fd,TCFLSH,pointer(qsel))=0;
  1262. {$else}
  1263. TCFlush:=fpIOCtl(fd,TIOCFLUSH,pointer(qsel))=0;
  1264. {$endif}
  1265. end;
  1266. Function IsATTY (Handle:Longint):Boolean;
  1267. {
  1268. Check if the filehandle described by 'handle' is a TTY (Terminal)
  1269. }
  1270. var
  1271. t : Termios;
  1272. begin
  1273. IsAtty:=TCGetAttr(Handle,t);
  1274. end;
  1275. Function IsATTY(var f: text):Boolean;
  1276. {
  1277. Idem as previous, only now for text variables.
  1278. }
  1279. begin
  1280. IsATTY:=IsaTTY(textrec(f).handle);
  1281. end;
  1282. function TTYName(Handle:Longint):string;
  1283. {
  1284. Return the name of the current tty described by handle f.
  1285. returns empty string in case of an error.
  1286. }
  1287. var
  1288. mydev,
  1289. myino : longint;
  1290. st : stat;
  1291. function mysearch(n:string): boolean;
  1292. {searches recursively for the device in the directory given by n,
  1293. returns true if found and sets the name of the device in ttyname}
  1294. var dirstream : pdir;
  1295. d : pdirent;
  1296. name : string;
  1297. st : stat;
  1298. begin
  1299. dirstream:=fpopendir(n);
  1300. if (linuxerror<>0) then
  1301. exit;
  1302. d:=fpReaddir(dirstream^);
  1303. while (d<>nil) do
  1304. begin
  1305. name:=n+'/'+strpas(@(d^.d_name));
  1306. fpstat(name,st);
  1307. if linuxerror=0 then
  1308. begin
  1309. if (fpS_ISDIR(st.st_mode)) and { if it is a directory }
  1310. (strpas(@(d^.d_name))<>'.') and { but not ., .. and fd subdirs }
  1311. (strpas(@(d^.d_name))<>'..') and
  1312. (strpas(@(d^.d_name))<>'') and
  1313. (strpas(@(d^.d_name))<>'fd') then
  1314. begin {we found a directory, search inside it}
  1315. if mysearch(name) then
  1316. begin {the device is here}
  1317. fpclosedir(dirstream^); {then don't continue searching}
  1318. mysearch:=true;
  1319. exit;
  1320. end;
  1321. end
  1322. else if (d^.d_fileno=myino) and (st.st_dev=mydev) then
  1323. begin
  1324. fpclosedir(dirstream^);
  1325. ttyname:=name;
  1326. mysearch:=true;
  1327. exit;
  1328. end;
  1329. end;
  1330. d:=fpReaddir(dirstream^);
  1331. end;
  1332. fpclosedir(dirstream^);
  1333. mysearch:=false;
  1334. end;
  1335. begin
  1336. TTYName:='';
  1337. fpfstat(handle,st);
  1338. if (fpgeterrno<>0) and isatty (handle) then
  1339. exit;
  1340. mydev:=st.st_dev;
  1341. myino:=st.st_ino;
  1342. mysearch('/dev');
  1343. end;
  1344. function TTYName(var F:Text):string;
  1345. {
  1346. Idem as previous, only now for text variables;
  1347. }
  1348. begin
  1349. TTYName:=TTYName(textrec(f).handle);
  1350. end;
  1351. {******************************************************************************
  1352. Utility calls
  1353. ******************************************************************************}
  1354. Function Octal(l:longint):longint;
  1355. {
  1356. Convert an octal specified number to decimal;
  1357. }
  1358. var
  1359. octnr,
  1360. oct : longint;
  1361. begin
  1362. octnr:=0;
  1363. oct:=0;
  1364. while (l>0) do
  1365. begin
  1366. oct:=oct or ((l mod 10) shl octnr);
  1367. l:=l div 10;
  1368. inc(octnr,3);
  1369. end;
  1370. Octal:=oct;
  1371. end;
  1372. {$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
  1373. {$DEFINE FPC_FEXPAND_GETENVPCHAR} { GetEnv result is a PChar }
  1374. {$I fexpand.inc}
  1375. {$UNDEF FPC_FEXPAND_GETENVPCHAR}
  1376. {$UNDEF FPC_FEXPAND_TILDE}
  1377. Function FSearch(const path:pathstr;dirlist:string):pathstr;
  1378. {
  1379. Searches for a file 'path' in the list of direcories in 'dirlist'.
  1380. returns an empty string if not found. Wildcards are NOT allowed.
  1381. If dirlist is empty, it is set to '.'
  1382. }
  1383. Var
  1384. NewDir : PathStr;
  1385. p1 : Longint;
  1386. Info : Stat;
  1387. Begin
  1388. {Replace ':' with ';'}
  1389. for p1:=1to length(dirlist) do
  1390. if dirlist[p1]=':' then
  1391. dirlist[p1]:=';';
  1392. {Check for WildCards}
  1393. If (Pos('?',Path) <> 0) or (Pos('*',Path) <> 0) Then
  1394. FSearch:='' {No wildcards allowed in these things.}
  1395. Else
  1396. Begin
  1397. Dirlist:='.;'+dirlist;{Make sure current dir is first to be searched.}
  1398. Repeat
  1399. p1:=Pos(';',DirList);
  1400. If p1=0 Then
  1401. p1:=255;
  1402. NewDir:=Copy(DirList,1,P1 - 1);
  1403. if NewDir[Length(NewDir)]<>'/' then
  1404. NewDir:=NewDir+'/';
  1405. NewDir:=NewDir+Path;
  1406. Delete(DirList,1,p1);
  1407. if FpStat(NewDir,Info)>=0 then
  1408. Begin
  1409. If Pos('./',NewDir)=1 Then
  1410. Delete(NewDir,1,2);
  1411. {DOS strips off an initial .\}
  1412. End
  1413. Else
  1414. NewDir:='';
  1415. Until (DirList='') or (Length(NewDir) > 0);
  1416. FSearch:=NewDir;
  1417. End;
  1418. End;
  1419. Procedure Globfree(var p : pglob);
  1420. {
  1421. Release memory occupied by pglob structure, and names in it.
  1422. sets p to nil.
  1423. }
  1424. var
  1425. temp : pglob;
  1426. begin
  1427. while assigned(p) do
  1428. begin
  1429. temp:=p^.next;
  1430. if assigned(p^.name) then
  1431. freemem(p^.name);
  1432. dispose(p);
  1433. p:=temp;
  1434. end;
  1435. end;
  1436. Function Glob(Const path:pathstr):pglob;
  1437. {
  1438. Fills a tglob structure with entries matching path,
  1439. and returns a pointer to it. Returns nil on error,
  1440. linuxerror is set accordingly.
  1441. }
  1442. var
  1443. temp,
  1444. temp2 : string[255];
  1445. thedir : pdir;
  1446. buffer : pdirent;
  1447. root,
  1448. current : pglob;
  1449. begin
  1450. { Get directory }
  1451. temp:=dirname(path);
  1452. if temp='' then
  1453. temp:='.';
  1454. temp:=temp+#0;
  1455. thedir:=fpopendir(@temp[1]);
  1456. if thedir=nil then
  1457. begin
  1458. glob:=nil;
  1459. linuxerror:=fpgeterrno;;
  1460. exit;
  1461. end;
  1462. temp:=basename(path,''); { get the pattern }
  1463. if thedir^.dd_fd<0 then
  1464. begin
  1465. linuxerror:=fpgeterrno;;
  1466. glob:=nil;
  1467. exit;
  1468. end;
  1469. {get the entries}
  1470. root:=nil;
  1471. current:=nil;
  1472. repeat
  1473. buffer:=fpreaddir(thedir^);
  1474. if buffer=nil then
  1475. break;
  1476. temp2:=strpas(@(buffer^.d_name[0]));
  1477. if fnmatch(temp,temp2) then
  1478. begin
  1479. if root=nil then
  1480. begin
  1481. new(root);
  1482. current:=root;
  1483. end
  1484. else
  1485. begin
  1486. new(current^.next);
  1487. current:=current^.next;
  1488. end;
  1489. if current=nil then
  1490. begin
  1491. linuxerror:=ESysENOMEM;
  1492. globfree(root);
  1493. break;
  1494. end;
  1495. current^.next:=nil;
  1496. getmem(current^.name,length(temp2)+1);
  1497. if current^.name=nil then
  1498. begin
  1499. linuxerror:=ESysENOMEM;
  1500. globfree(root);
  1501. break;
  1502. end;
  1503. move(buffer^.d_name[0],current^.name^,length(temp2)+1);
  1504. end;
  1505. until false;
  1506. fpclosedir(thedir^);
  1507. glob:=root;
  1508. end;
  1509. Function GetFS (var T:Text):longint;
  1510. {
  1511. Get File Descriptor of a text file.
  1512. }
  1513. begin
  1514. if textrec(t).mode=fmclosed then
  1515. exit(-1)
  1516. else
  1517. GETFS:=textrec(t).Handle
  1518. end;
  1519. Function GetFS(Var F:File):longint;
  1520. {
  1521. Get File Descriptor of an unTyped file.
  1522. }
  1523. begin
  1524. { Handle and mode are on the same place in textrec and filerec. }
  1525. if filerec(f).mode=fmclosed then
  1526. exit(-1)
  1527. else
  1528. GETFS:=filerec(f).Handle
  1529. end;
  1530. {--------------------------------
  1531. Stat.Mode Macro's
  1532. --------------------------------}
  1533. Initialization
  1534. InitLocalTime;
  1535. finalization
  1536. DoneLocalTime;
  1537. End.
  1538. {
  1539. $Log$
  1540. Revision 1.41 2003-10-12 19:40:43 marco
  1541. * ioctl fixes. IDE now starts, but
  1542. Revision 1.40 2003/09/29 14:36:06 peter
  1543. * fixed for stricter compiler
  1544. Revision 1.39 2003/09/27 12:51:33 peter
  1545. * fpISxxx macros renamed to C compliant fpS_ISxxx
  1546. Revision 1.38 2003/09/20 12:38:29 marco
  1547. * FCL now compiles for FreeBSD with new 1.1. Now Linux.
  1548. Revision 1.37 2003/09/17 19:07:44 marco
  1549. * more fixes for Unix<->unixutil
  1550. Revision 1.36 2003/09/17 17:30:46 marco
  1551. * Introduction of unixutil
  1552. Revision 1.35 2003/09/16 21:46:27 marco
  1553. * small fixes, checking things on linux
  1554. Revision 1.34 2003/09/16 20:52:24 marco
  1555. * small cleanups. Mostly killing of already commented code in unix etc
  1556. Revision 1.33 2003/09/16 16:13:56 marco
  1557. * fdset functions renamed to fp<posix name>
  1558. Revision 1.32 2003/09/15 20:08:49 marco
  1559. * small fixes. FreeBSD now cycles
  1560. Revision 1.31 2003/09/14 20:15:01 marco
  1561. * Unix reform stage two. Remove all calls from Unix that exist in Baseunix.
  1562. Revision 1.30 2003/07/08 21:23:24 peter
  1563. * sparc fixes
  1564. Revision 1.29 2003/05/30 19:58:40 marco
  1565. * Getting NetBSD/i386 to compile.
  1566. Revision 1.28 2003/05/29 19:16:16 marco
  1567. * fixed a small *BSD gotcha
  1568. Revision 1.27 2003/05/24 20:39:54 jonas
  1569. * fixed ExitCode translation in WaitProcess for Linux and Darwin (and
  1570. probably other BSD's as well)
  1571. Revision 1.26 2003/03/11 08:27:59 michael
  1572. * stringtoppchar should use tabs instead of backspace as delimiter
  1573. Revision 1.25 2002/12/18 16:50:39 marco
  1574. * Unix RTL generic parts. Linux working, *BSD will follow shortly
  1575. Revision 1.24 2002/09/07 16:01:28 peter
  1576. * old logs removed and tabs fixed
  1577. Revision 1.23 2002/08/06 13:30:46 sg
  1578. * replaced some Longints with Cardinals, to mach the C headers
  1579. * updated the termios record
  1580. Revision 1.22 2002/03/05 20:04:25 michael
  1581. + Patch from Sebastian for FCNTL call
  1582. Revision 1.21 2002/01/02 12:22:54 marco
  1583. * Removed ifdef arround getepoch.
  1584. }