unix.pp 45 KB

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