unix.pp 34 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2000 by Michael Van Canneyt,
  4. BSD parts (c) 2000 by Marco van de Voort
  5. members of the Free Pascal development team.
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY;without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. Unit Unix;
  13. Interface
  14. Uses
  15. BaseUnix,UnixType;
  16. // If you deprecated new symbols, please annotate the version.
  17. // this makes it easier to decide if they can already be removed.
  18. {$if (defined(BSD) or defined(SUNOS)) and defined(FPC_USE_LIBC)}
  19. {$define USE_VFORK}
  20. {$endif}
  21. {$i aliasptp.inc}
  22. {$i unxconst.inc} { Get Types and Constants only exported in this unit }
  23. {** File handling **}
  24. Const
  25. P_IN = 1; // pipes (?)
  26. P_OUT = 2;
  27. LOCK_SH = 1; // flock constants ?
  28. LOCK_EX = 2;
  29. LOCK_UN = 8;
  30. LOCK_NB = 4;
  31. // The portable MAP_* and PROT_ constants are exported from unit Unix for compability.
  32. PROT_READ = baseunix.PROT_READ; { page can be read }
  33. PROT_WRITE = baseunix.PROT_WRITE; { page can be written }
  34. PROT_EXEC = baseunix.PROT_EXEC; { page can be executed }
  35. PROT_NONE = baseunix.PROT_NONE; { page can not be accessed }
  36. MAP_FAILED = baseunix.MAP_FAILED; { mmap() failed }
  37. MAP_SHARED = baseunix.MAP_SHARED; { Share changes }
  38. MAP_PRIVATE = baseunix.MAP_PRIVATE; { Changes are private }
  39. MAP_TYPE = baseunix.MAP_TYPE; { Mask for type of mapping }
  40. MAP_FIXED = baseunix.MAP_FIXED; { Interpret addr exactly }
  41. {** Time/Date Handling **}
  42. var
  43. tzdaylight : boolean;
  44. tzname : array[boolean] of pchar;
  45. {************ Procedure/Functions ************}
  46. {$ifdef android}
  47. {$define DONT_READ_TIMEZONE}
  48. {$endif android}
  49. {$IFNDEF DONT_READ_TIMEZONE} // allows to disable linking in and trying for platforms
  50. // it doesn't (yet) work for.
  51. { timezone support }
  52. procedure GetLocalTimezone(timer:cint;var leap_correct,leap_hit:cint);
  53. procedure GetLocalTimezone(timer:cint);
  54. procedure ReadTimezoneFile(fn:string);
  55. function GetTimezoneFile:string;
  56. Procedure ReReadLocalTime;
  57. {$ENDIF}
  58. {** Process Handling **}
  59. function FpExecLE (Const PathName:RawByteString;const S:Array Of RawByteString;MyEnv:ppchar):cint;
  60. function FpExecL (Const PathName:RawByteString;const S:Array Of RawByteString):cint;
  61. function FpExecLP (Const PathName:RawByteString;const S:Array Of RawByteString):cint;
  62. function FpExecLPE(Const PathName:RawByteString;const S:Array Of RawByteString;env:ppchar):cint;
  63. function FpExecV (Const PathName:RawByteString;args:ppchar):cint;
  64. function FpExecVP (Const PathName:RawByteString;args:ppchar):cint;
  65. function FpExecVPE(Const PathName:RawByteString;args,env:ppchar):cint;
  66. Function fpSystem(const Command:RawByteString):cint;
  67. Function WaitProcess (Pid:cint):cint;
  68. Function WIFSTOPPED (Status: Integer): Boolean;
  69. Function W_EXITCODE (ReturnCode, Signal: Integer): Integer;
  70. Function W_STOPCODE (Signal: Integer): Integer;
  71. {** File Handling **}
  72. Function fpFlock (var T : text;mode : cint) : cint;
  73. Function fpFlock (var F : File;mode : cint) : cint;
  74. {** Directory Handling **}
  75. procedure SeekDir(p:pdir;loc:clong);
  76. function TellDir(p:pdir):TOff;
  77. {** Pipe/Fifo/Stream **}
  78. Function AssignPipe (var pipe_in,pipe_out:cint):cint;
  79. Function AssignPipe (var pipe_in,pipe_out:text):cint;
  80. Function AssignPipe (var pipe_in,pipe_out:file):cint;
  81. Function POpen (var F:text;const Prog:RawByteString;rw:char):cint;
  82. Function POpen (var F:file;const Prog:RawByteString;rw:char):cint;
  83. Function POpen (var F:text;const Prog:UnicodeString;rw:char):cint;
  84. Function POpen (var F:file;const Prog:UnicodeString;rw:char):cint;
  85. Function AssignStream(Var StreamIn,Streamout:text;Const Prog:ansiString;const args : array of ansistring) : cint;
  86. Function AssignStream(Var StreamIn,Streamout,streamerr:text;Const Prog:ansiString;const args : array of ansistring) : cint;
  87. Function GetDomainName:String; deprecated; // because linux only.
  88. Function GetHostName:String;
  89. {** Utility functions **}
  90. Type
  91. TFSearchOption = (NoCurrentDirectory,
  92. CurrentDirectoryFirst,
  93. CurrentDirectoryLast);
  94. Function FSearch (const path:RawByteString;dirlist:RawByteString;CurrentDirStrategy:TFSearchOption):RawByteString;
  95. Function FSearch (const path:RawByteString;dirlist:RawByteString):RawByteString;
  96. Function FSearch (const path:UnicodeString;dirlist:UnicodeString;CurrentDirStrategy:TFSearchOption):UnicodeString;
  97. Function FSearch (const path:UnicodeString;dirlist:UnicodeString):UnicodeString;
  98. {$ifdef FPC_USE_LIBC}
  99. const clib = 'c';
  100. {$i unxdeclh.inc}
  101. {$else}
  102. {$i unxsysch.inc} // calls used in system and not reexported from baseunix
  103. {$endif}
  104. {******************************************************************************
  105. Implementation
  106. ******************************************************************************}
  107. {$i unxovlh.inc}
  108. Implementation
  109. Uses
  110. UnixUtil // tzseconds
  111. {$ifndef FPC_USE_LIBC},Syscall{$endif}
  112. ;
  113. {$i unxovl.inc}
  114. {$ifndef FPC_USE_LIBC}
  115. {$i syscallh.inc}
  116. {$i unxsysc.inc}
  117. {$endif}
  118. {$i unxfunc.inc} { Platform specific implementations }
  119. Function getenv(name:string):Pchar; external name 'FPC_SYSC_FPGETENV';
  120. {******************************************************************************
  121. Process related calls
  122. ******************************************************************************}
  123. { Most calls of WaitPID do not handle the result correctly, this funktion treats errors more correctly }
  124. 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}
  125. var
  126. r,s : cint;
  127. begin
  128. s:=$7F00;
  129. repeat
  130. r:=fpWaitPid(Pid,@s,0);
  131. if (r=-1) and (fpgeterrno=ESysEIntr) Then
  132. r:=0;
  133. until (r<>0);
  134. if (r=-1) or (r=0) then // 0 is not a valid return and should never occur (it means status invalid when using WNOHANG)
  135. WaitProcess:=-1 // return -1 to indicate an error. fpwaitpid updated it.
  136. else
  137. begin
  138. if wifexited(s) then
  139. WaitProcess:=wexitstatus(s)
  140. else if (s>0) then // Until now there is not use of the highest bit , but check this for the future
  141. WaitProcess:=-s // normal case
  142. else
  143. WaitProcess:=s; // s<0 should not occur, but wie return also a negativ value
  144. end;
  145. end;
  146. function intFpExecVEMaybeP (Const PathName:RawByteString;Args,MyEnv:ppchar;SearchPath:Boolean):cint;
  147. // does an ExecVE, but still has to handle P
  148. // execv variants call this directly, execl variants indirectly via
  149. // intfpexecl
  150. Var
  151. NewCmd : RawByteString;
  152. ThePath : RawByteString;
  153. Begin
  154. If SearchPath and (pos('/',pathname)=0) Then
  155. Begin
  156. // The above could be better. (check if not escaped/quoted '/'s) ?
  157. // (Jilles says this is ok)
  158. // Stevens says only search if newcmd contains no '/'
  159. // fsearch is not ansistring clean yet.
  160. ThePath:=fpgetenv('PATH');
  161. SetCodePage(ThePath,DefaultSystemCodePage,false);
  162. SetCodePage(ThePath,DefaultFileSystemCodePage,true);
  163. if thepath='' then
  164. thepath:='.'; // FreeBSD uses _PATH_DEFPATH = /usr/bin:/bin
  165. // but a quick check showed that _PATH_DEFPATH
  166. // varied from OS to OS
  167. newcmd:=ToSingleByteFileSystemEncodedFileName(FSearch(pathname,thepath,NoCurrentDirectory));
  168. // FreeBSD libc keeps on trying till a file is successfully run.
  169. // Stevens says "try each path prefix"
  170. // execp puts newcmd here.
  171. args^:=pchar(newcmd);
  172. End else
  173. newcmd:=ToSingleByteFileSystemEncodedFileName(pathname);
  174. // repeat
  175. // if searchpath then args^:=pchar(commandtorun)
  176. IntFpExecVEMaybeP:=fpExecVE(newcmd,Args,MyEnv);
  177. {
  178. // Code that if exec fails due to permissions, tries to run it with sh
  179. // Should we deallocate p on fail? -> no fpexit is run no matter what
  180. //
  181. }
  182. // if intfpexecvemaybep=-1 then seach next file.
  183. // until (Goexit) or SearchExit;
  184. {
  185. If IntFpExec=-1 Then
  186. Begin
  187. Error:=fpGetErrno
  188. Case Error of
  189. ESysE2Big : Exit(-1);
  190. ESysELoop,
  191. : Exit(-1);
  192. }
  193. end;
  194. function intFpExecl (Const PathName:RawByteString;const s:array of RawByteString;MyEnv:ppchar;SearchPath:Boolean):cint;
  195. { Handles the array of ansistring -> ppchar conversion.
  196. Base for the the "l" variants.
  197. }
  198. var p:ppchar;
  199. i:integer;
  200. s2:array of Rawbytestring;
  201. begin
  202. If PathName='' Then
  203. Begin
  204. fpsetErrno(ESysEnoEnt);
  205. Exit(-1); // Errno?
  206. End;
  207. setlength(s2,high(s)+1);
  208. for i:=low(s) to high(s) do
  209. s2[i]:=ToSingleByteFileSystemEncodedFileName(s[i]);
  210. p:=ArrayStringToPPchar(s2,1);
  211. if p=NIL Then
  212. Begin
  213. GetMem(p,2*sizeof(pchar));
  214. if p=nil then
  215. begin
  216. {$ifdef xunix}
  217. fpseterrno(ESysEnoMem);
  218. {$endif}
  219. fpseterrno(ESysEnoEnt);
  220. exit(-1);
  221. end;
  222. p[1]:=nil;
  223. End;
  224. p^:=pchar(PathName);
  225. IntFPExecL:=intFpExecVEMaybeP(PathName,p,MyEnv,SearchPath);
  226. // If we come here, no attempts were executed successfully.
  227. Freemem(p);
  228. end;
  229. function FpExecLE (Const PathName:RawByteString;const S:Array Of RawByteString;MyEnv:ppchar):cint;
  230. Begin
  231. FpExecLE:=intFPExecl(PathName,s,MyEnv,false);
  232. End;
  233. function FpExecL(Const PathName:RawByteString;const S:Array Of RawByteString):cint;
  234. Begin
  235. FpExecL:=intFPExecl(PathName,S,EnvP,false);
  236. End;
  237. function FpExecLP(Const PathName:RawByteString;const S:Array Of RawByteString):cint;
  238. Begin
  239. FpExecLP:=intFPExecl(PathName,S,EnvP,True);
  240. End;
  241. function FpExecLPE(Const PathName:RawByteString;const S:Array Of RawByteString;env:ppchar):cint;
  242. Begin
  243. FpExecLPE:=intFPExecl(PathName,S,Env,True);
  244. End;
  245. function FpExecV(Const PathName:RawByteString;args:ppchar):cint;
  246. Begin
  247. fpexecV:=intFpExecVEMaybeP (PathName,args,envp,false);
  248. End;
  249. function FpExecVP(Const PathName:RawByteString;args:ppchar):cint;
  250. Begin
  251. fpexecVP:=intFpExecVEMaybeP (PathName,args,envp,true);
  252. End;
  253. function FpExecVPE(Const PathName:RawByteString;args,env:ppchar):cint;
  254. Begin
  255. fpexecVPE:=intFpExecVEMaybeP (PathName,args,env,true);
  256. End;
  257. // exect and execvP (ExecCapitalP) are not implement
  258. // Non POSIX anyway.
  259. // Exect turns on tracing for the process
  260. // execvP has the searchpath as array of ansistring ( const char *search_path)
  261. {$define FPC_USE_FPEXEC}
  262. {$if defined(FPC_USE_FPEXEC) and not defined(USE_VFORK)}
  263. {$define SHELL_USE_FPEXEC}
  264. {$endif}
  265. {$ifdef FPC_USE_LIBC}
  266. function xfpsystem(p:pchar):cint; cdecl; external clib name 'system';
  267. Function fpSystem(const Command:RawByteString):cint;
  268. var
  269. cmd: RawByteString;
  270. begin
  271. cmd:=ToSingleByteFileSystemEncodedFileName(Command);
  272. fpsystem:=xfpsystem(pchar(cmd));
  273. end;
  274. {$else}
  275. Function fpSystem(const Command:RawByteString):cint;
  276. var
  277. pid,savedpid : cint;
  278. pstat : cint;
  279. ign,intact,
  280. quitact : SigactionRec;
  281. newsigblock,
  282. oldsigblock : tsigset;
  283. {$ifndef SHELL_USE_FPEXEC}
  284. p : ppchar;
  285. {$endif}
  286. cmd : RawByteString;
  287. begin { Changes as above }
  288. { fpexec* take care of converting the command to the right code page }
  289. if command='' then exit(1);
  290. {$ifndef SHELL_USE_FPEXEC}
  291. p:=CreateShellArgv(command);
  292. {$endif}
  293. ign.sa_handler:=SigActionHandler(SIG_IGN);
  294. fpsigemptyset(ign.sa_mask);
  295. ign.sa_flags:=0;
  296. fpsigaction(SIGINT, @ign, @intact);
  297. fpsigaction(SIGQUIT, @ign, @quitact);
  298. fpsigemptyset(newsigblock);
  299. fpsigaddset(newsigblock,SIGCHLD);
  300. fpsigprocmask(SIG_BLOCK,newsigblock,oldsigblock);
  301. {$ifdef USE_VFORK}
  302. pid:=fpvfork;
  303. {$else USE_VFORK}
  304. pid:=fpfork;
  305. {$endif USE_VFORK}
  306. if pid=0 then // We are in the Child
  307. begin
  308. fpsigaction(SIGINT,@intact,NIL);
  309. fpsigaction(SIGQUIT,@quitact,NIL);
  310. fpsigprocmask(SIG_SETMASK,@oldsigblock,NIL);
  311. {$ifndef SHELL_USE_FPEXEC}
  312. fpExecve(p^,p,envp);
  313. {$else}
  314. fpexecl('/bin/sh',['-c',Command]);
  315. {$endif}
  316. fpExit(127); // was exit(127)!! We must exit the Process, not the function
  317. end
  318. else if (pid<>-1) then // Successfull started
  319. begin
  320. savedpid:=pid;
  321. repeat
  322. pid:=fpwaitpid(savedpid,@pstat,0);
  323. until (pid<>-1) and (fpgeterrno()<>ESysEintr);
  324. if pid=-1 Then
  325. fpsystem:=-1
  326. else
  327. fpsystem:=pstat;
  328. end
  329. else // no success
  330. fpsystem:=-1;
  331. fpsigaction(SIGINT,@intact,NIL);
  332. fpsigaction(SIGQUIT,@quitact,NIL);
  333. fpsigprocmask(SIG_SETMASK,@oldsigblock,NIL);
  334. {$ifndef SHELL_USE_FPEXEC}
  335. FreeShellArgV(p);
  336. {$endif}
  337. end;
  338. {$endif}
  339. Function WIFSTOPPED(Status: Integer): Boolean;
  340. begin
  341. WIFSTOPPED:=((Status and $FF)=$7F);
  342. end;
  343. Function W_EXITCODE(ReturnCode, Signal: Integer): Integer;
  344. begin
  345. W_EXITCODE:=(ReturnCode shl 8) or Signal;
  346. end;
  347. Function W_STOPCODE(Signal: Integer): Integer;
  348. begin
  349. W_STOPCODE:=(Signal shl 8) or $7F;
  350. end;
  351. {$IFNDEF DONT_READ_TIMEZONE}
  352. { Include timezone handling routines which use /usr/share/timezone info }
  353. {$i timezone.inc}
  354. {$endif}
  355. {******************************************************************************
  356. FileSystem calls
  357. ******************************************************************************}
  358. Function fpFlock (var T : text;mode : cint) : cint;
  359. begin
  360. {$ifndef beos}
  361. fpFlock:=fpFlock(TextRec(T).Handle,mode);
  362. {$endif}
  363. end;
  364. Function fpFlock (var F : File;mode : cint) :cint;
  365. begin
  366. {$ifndef beos}
  367. fpFlock:=fpFlock(FileRec(F).Handle,mode);
  368. {$endif}
  369. end;
  370. Function SelectText(var T:Text;TimeOut :PTimeval):cint;
  371. Var
  372. F:TfdSet;
  373. begin
  374. if textrec(t).mode=fmclosed then
  375. begin
  376. fpseterrno(ESysEBADF);
  377. exit(-1);
  378. end;
  379. FpFD_ZERO(f);
  380. fpFD_SET(textrec(T).handle,f);
  381. if textrec(T).mode=fminput then
  382. SelectText:=fpselect(textrec(T).handle+1,@f,nil,nil,TimeOut)
  383. else
  384. SelectText:=fpselect(textrec(T).handle+1,nil,@f,nil,TimeOut);
  385. end;
  386. Function SelectText(var T:Text;TimeOut :cint):cint;
  387. var
  388. p : PTimeVal;
  389. tv : TimeVal;
  390. begin
  391. if TimeOut=-1 then
  392. p:=nil
  393. else
  394. begin
  395. tv.tv_Sec:=Timeout div 1000;
  396. tv.tv_Usec:=(Timeout mod 1000)*1000;
  397. p:=@tv;
  398. end;
  399. SelectText:=SelectText(T,p);
  400. end;
  401. {******************************************************************************
  402. Directory
  403. ******************************************************************************}
  404. procedure SeekDir(p:pdir;loc:clong);
  405. begin
  406. if p=nil then
  407. begin
  408. fpseterrno(ESysEBADF);
  409. exit;
  410. end;
  411. {$if not(defined(bsd)) and not(defined(solaris)) and not(defined(beos)) and not(defined(aix)) }
  412. p^.dd_nextoff:=fplseek(p^.dd_fd,loc,seek_set);
  413. {$endif}
  414. {$if not(defined(beos))}
  415. p^.dd_size:=0;
  416. p^.dd_loc:=0;
  417. {$endif}
  418. end;
  419. function TellDir(p:pdir):TOff;
  420. begin
  421. if p=nil then
  422. begin
  423. fpseterrno(ESysEBADF);
  424. telldir:=-1;
  425. exit;
  426. end;
  427. {$ifndef beos}
  428. telldir:=fplseek(p^.dd_fd,0,seek_cur)
  429. {$endif}
  430. { We could try to use the nextoff field here, but on my 1.2.13
  431. kernel, this gives nothing... This may have to do with
  432. the readdir implementation of libc... I also didn't find any trace of
  433. the field in the kernel code itself, So I suspect it is an artifact of libc.
  434. Michael. }
  435. end;
  436. {******************************************************************************
  437. Pipes/Fifo
  438. ******************************************************************************}
  439. Procedure OpenPipe(var F:Text);
  440. begin
  441. case textrec(f).mode of
  442. fmoutput :
  443. if textrec(f).userdata[1]<>P_OUT then
  444. textrec(f).mode:=fmclosed;
  445. fminput :
  446. if textrec(f).userdata[1]<>P_IN then
  447. textrec(f).mode:=fmclosed;
  448. else
  449. textrec(f).mode:=fmclosed;
  450. end;
  451. end;
  452. Function IOPipe(var F:text):cint;
  453. begin
  454. IOPipe:=0;
  455. case textrec(f).mode of
  456. fmoutput :
  457. begin
  458. { first check if we need something to write, else we may
  459. get a SigPipe when Close() is called (PFV) }
  460. if textrec(f).bufpos>0 then
  461. IOPipe:=fpwrite(textrec(f).handle,pchar(textrec(f).bufptr),textrec(f).bufpos);
  462. end;
  463. fminput : Begin
  464. textrec(f).bufend:=fpread(textrec(f).handle,pchar(textrec(f).bufptr),textrec(f).bufsize);
  465. IOPipe:=textrec(f).bufend;
  466. End;
  467. end;
  468. textrec(f).bufpos:=0;
  469. end;
  470. Function FlushPipe(var F:Text):cint;
  471. begin
  472. FlushPipe:=0;
  473. if (textrec(f).mode=fmoutput) and (textrec(f).bufpos<>0) then
  474. FlushPipe:=IOPipe(f);
  475. textrec(f).bufpos:=0;
  476. end;
  477. Function ClosePipe(var F:text):cint;
  478. begin
  479. textrec(f).mode:=fmclosed;
  480. ClosePipe:=fpclose(textrec(f).handle);
  481. end;
  482. Function AssignPipe(var pipe_in,pipe_out:text):cint;
  483. {
  484. Sets up a pair of file variables, which act as a pipe. The first one can
  485. be read from, the second one can be written to.
  486. }
  487. var
  488. f_in,f_out : cint;
  489. begin
  490. if AssignPipe(f_in,f_out)=-1 then
  491. exit(-1);
  492. { Set up input }
  493. Assign(Pipe_in,'');
  494. Textrec(Pipe_in).Handle:=f_in;
  495. Textrec(Pipe_in).Mode:=fmInput;
  496. Textrec(Pipe_in).userdata[1]:=P_IN;
  497. TextRec(Pipe_in).OpenFunc:=@OpenPipe;
  498. TextRec(Pipe_in).InOutFunc:=@IOPipe;
  499. TextRec(Pipe_in).FlushFunc:=@FlushPipe;
  500. TextRec(Pipe_in).CloseFunc:=@ClosePipe;
  501. { Set up output }
  502. Assign(Pipe_out,'');
  503. Textrec(Pipe_out).Handle:=f_out;
  504. Textrec(Pipe_out).Mode:=fmOutput;
  505. Textrec(Pipe_out).userdata[1]:=P_OUT;
  506. TextRec(Pipe_out).OpenFunc:=@OpenPipe;
  507. TextRec(Pipe_out).InOutFunc:=@IOPipe;
  508. TextRec(Pipe_out).FlushFunc:=@FlushPipe;
  509. TextRec(Pipe_out).CloseFunc:=@ClosePipe;
  510. AssignPipe:=0;
  511. end;
  512. Function AssignPipe(var pipe_in,pipe_out:file):cint;
  513. {
  514. Sets up a pair of file variables, which act as a pipe. The first one can
  515. be read from, the second one can be written to.
  516. If the operation was unsuccesful,
  517. }
  518. var
  519. f_in,f_out : cint;
  520. begin
  521. if AssignPipe(f_in,f_out)=-1 then
  522. exit(-1);
  523. { Set up input }
  524. Assign(Pipe_in,'');
  525. Filerec(Pipe_in).Handle:=f_in;
  526. Filerec(Pipe_in).Mode:=fmInput;
  527. Filerec(Pipe_in).recsize:=1;
  528. Filerec(Pipe_in).userdata[1]:=P_IN;
  529. { Set up output }
  530. Assign(Pipe_out,'');
  531. Filerec(Pipe_out).Handle:=f_out;
  532. Filerec(Pipe_out).Mode:=fmoutput;
  533. Filerec(Pipe_out).recsize:=1;
  534. Filerec(Pipe_out).userdata[1]:=P_OUT;
  535. AssignPipe:=0;
  536. end;
  537. Function PCloseText(Var F:text):cint;
  538. {
  539. May not use @PClose due overloading
  540. }
  541. begin
  542. PCloseText:=PClose(f);
  543. end;
  544. Function POpen_internal(var F:text;const Prog:RawByteString;rw:char):cint;
  545. {
  546. Starts the program in 'Prog' and makes it's input or out put the
  547. other end of a pipe. If rw is 'w' or 'W', then whatever is written to
  548. F, will be read from stdin by the program in 'Prog'. The inverse is true
  549. for 'r' or 'R' : whatever the program in 'Prog' writes to stdout, can be
  550. read from 'f'.
  551. }
  552. var
  553. pipi,
  554. pipo : text;
  555. pid : cint;
  556. pl : ^cint;
  557. {$if not defined(FPC_USE_FPEXEC) or defined(USE_VFORK)}
  558. pp : array[0..3] of pchar;
  559. temp : string[255];
  560. {$endif not FPC_USE_FPEXEC or USE_VFORK}
  561. ret : cint;
  562. begin
  563. rw:=upcase(rw);
  564. if not (rw in ['R','W']) then
  565. begin
  566. FpSetErrno(ESysEnoent);
  567. exit(-1);
  568. end;
  569. ret:=AssignPipe(pipi,pipo);
  570. if ret=-1 then
  571. exit(-1);
  572. {$ifdef USE_VFORK}
  573. pid:=fpvfork;
  574. {$else USE_VFORK}
  575. pid:=fpfork;
  576. {$endif USE_VFORK}
  577. if pid=-1 then
  578. begin
  579. close(pipi);
  580. close(pipo);
  581. exit(-1);
  582. end;
  583. if pid=0 then
  584. begin
  585. { We're in the child }
  586. if rw='W' then
  587. begin
  588. if (textrec(pipi).handle <> stdinputhandle) then
  589. begin
  590. ret:=fpdup2(pipi,input);
  591. {$ifdef USE_VFORK}
  592. fpclose(textrec(pipi).handle);
  593. {$else USE_VFORK}
  594. close(pipi);
  595. {$endif USE_VFORK}
  596. end;
  597. {$ifdef USE_VFORK}
  598. fpclose(textrec(pipo).handle);
  599. {$else USE_VFORK}
  600. close(pipo);
  601. {$endif USE_VFORK}
  602. if ret=-1 then
  603. fpexit(127);
  604. end
  605. else
  606. begin
  607. {$ifdef USE_VFORK}
  608. fpclose(textrec(pipi).handle);
  609. {$else USE_VFORK}
  610. close(pipi);
  611. {$endif USE_VFORK}
  612. if (textrec(pipo).handle <> stdoutputhandle) then
  613. begin
  614. ret:=fpdup2(pipo,output);
  615. {$ifdef USE_VFORK}
  616. fpclose(textrec(pipo).handle);
  617. {$else USE_VFORK}
  618. close(pipo);
  619. {$endif USE_VFORK}
  620. end;
  621. if ret=-1 then
  622. fpexit(127);
  623. end;
  624. {$if defined(FPC_USE_FPEXEC) and not defined(USE_VFORK)}
  625. fpexecl(pchar('/bin/sh'),['-c',Prog]);
  626. {$else}
  627. temp:='/bin/sh'#0'-c'#0;
  628. pp[0]:=@temp[1];
  629. pp[1]:=@temp[9];
  630. pp[2]:=@prog[1];
  631. pp[3]:=Nil;
  632. fpExecve('/bin/sh',@pp,envp);
  633. {$endif}
  634. fpexit(127);
  635. end
  636. else
  637. begin
  638. { We're in the parent }
  639. if rw='W' then
  640. begin
  641. close(pipi);
  642. f:=pipo;
  643. end
  644. else
  645. begin
  646. close(pipo);
  647. f:=pipi;
  648. end;
  649. textrec(f).bufptr:=@textrec(f).buffer;
  650. {Save the process ID - needed when closing }
  651. pl:=pcint(@textrec(f).userdata[2]);
  652. { avoid alignment error on sparc }
  653. move(pid,pl^,sizeof(pid));
  654. textrec(f).closefunc:=@PCloseText;
  655. end;
  656. POpen_internal:=0;
  657. end;
  658. Function POpen_internal(var F:file;const Prog:RawByteString;rw:char):cint;
  659. {
  660. Starts the program in 'Prog' and makes it's input or out put the
  661. other end of a pipe. If rw is 'w' or 'W', then whatever is written to
  662. F, will be read from stdin by the program in 'Prog'. The inverse is true
  663. for 'r' or 'R' : whatever the program in 'Prog' writes to stdout, can be
  664. read from 'f'.
  665. }
  666. var
  667. pipi,
  668. pipo : file;
  669. pid : cint;
  670. pl : ^cint;
  671. {$if not defined(FPC_USE_FPEXEC) or defined(USE_VFORK)}
  672. pp : array[0..3] of pchar;
  673. temp : string[255];
  674. {$endif not FPC_USE_FPEXEC or USE_VFORK}
  675. ret : cint;
  676. begin
  677. rw:=upcase(rw);
  678. if not (rw in ['R','W']) then
  679. begin
  680. FpSetErrno(ESysEnoent);
  681. exit(-1);
  682. end;
  683. ret:=AssignPipe(pipi,pipo);
  684. if ret=-1 then
  685. exit(-1);
  686. {$ifdef USE_VFORK}
  687. pid:=fpvfork;
  688. {$else USE_VFORK}
  689. pid:=fpfork;
  690. {$endif USE_VFORK}
  691. if pid=-1 then
  692. begin
  693. close(pipi);
  694. close(pipo);
  695. exit(-1);
  696. end;
  697. if pid=0 then
  698. begin
  699. { We're in the child }
  700. if rw='W' then
  701. begin
  702. if (filerec(pipi).handle <> stdinputhandle) then
  703. begin
  704. ret:=fpdup2(filerec(pipi).handle,stdinputhandle);
  705. {$ifdef USE_VFORK}
  706. fpclose(filerec(pipi).handle);
  707. {$else USE_VFORK}
  708. close(pipi);
  709. {$endif USE_VFORK}
  710. end;
  711. {$ifdef USE_VFORK}
  712. fpclose(filerec(pipo).handle);
  713. {$else USE_VFORK}
  714. close(pipo);
  715. {$endif USE_VFORK}
  716. if ret=-1 then
  717. fpexit(127);
  718. end
  719. else
  720. begin
  721. {$ifdef USE_VFORK}
  722. fpclose(filerec(pipi).handle);
  723. {$else USE_VFORK}
  724. close(pipi);
  725. {$endif USE_VFORK}
  726. if (filerec(pipo).handle <> stdoutputhandle) then
  727. begin
  728. ret:=fpdup2(filerec(pipo).handle,stdoutputhandle);
  729. {$ifdef USE_VFORK}
  730. fpclose(filerec(pipo).handle);
  731. {$else USE_VFORK}
  732. close(pipo);
  733. {$endif USE_VFORK}
  734. end;
  735. if ret=-1 then
  736. fpexit(127);
  737. end;
  738. {$if defined(FPC_USE_FPEXEC) and not defined(USE_VFORK)}
  739. fpexecl(pchar('/bin/sh'),['-c',Prog]);
  740. {$else}
  741. temp:='/bin/sh'#0'-c'#0;
  742. pp[0]:=@temp[1];
  743. pp[1]:=@temp[9];
  744. pp[2]:=@prog[1];
  745. pp[3]:=Nil;
  746. fpExecve('/bin/sh',@pp,envp);
  747. {$endif}
  748. fpexit(127);
  749. end
  750. else
  751. begin
  752. { We're in the parent }
  753. if rw='W' then
  754. begin
  755. close(pipi);
  756. f:=pipo;
  757. end
  758. else
  759. begin
  760. close(pipo);
  761. f:=pipi;
  762. end;
  763. {Save the process ID - needed when closing }
  764. pl:=pcint(@filerec(f).userdata[2]);
  765. { avoid alignment error on sparc }
  766. move(pid,pl^,sizeof(pid));
  767. end;
  768. POpen_internal:=0;
  769. end;
  770. Function POpen(var F:text;const Prog:RawByteString;rw:char):cint;
  771. begin
  772. { can't do the ToSingleByteFileSystemEncodedFileName() conversion inside
  773. POpen_internal, because this may destroy the temp rawbytestring result
  774. of that function in the parent before the child is finished with it }
  775. POpen:=POpen_internal(F,ToSingleByteFileSystemEncodedFileName(Prog),rw);
  776. end;
  777. Function POpen(var F:file;const Prog:RawByteString;rw:char):cint;
  778. begin
  779. { can't do the ToSingleByteFileSystemEncodedFileName() conversion inside
  780. POpen_internal, because this may destroy the temp rawbytestring result
  781. of that function in the parent before the child is finished with it }
  782. POpen:=POpen_internal(F,ToSingleByteFileSystemEncodedFileName(Prog),rw);
  783. end;
  784. function POpen(var F: text; const Prog: UnicodeString; rw: char): cint;
  785. begin
  786. POpen:=POpen_internal(F,ToSingleByteFileSystemEncodedFileName(Prog),rw);
  787. end;
  788. function POpen(var F: file; const Prog: UnicodeString; rw: char): cint;
  789. begin
  790. POpen:=POpen_internal(F,ToSingleByteFileSystemEncodedFileName(Prog),rw);
  791. end;
  792. Function AssignStream(Var StreamIn,Streamout:text;Const Prog:ansiString;const args : array of ansistring) : cint;
  793. {
  794. Starts the program in 'Prog' and makes its input and output the
  795. other end of two pipes, which are the stdin and stdout of a program
  796. specified in 'Prog'.
  797. streamout can be used to write to the program, streamin can be used to read
  798. the output of the program. See the following diagram :
  799. Parent Child
  800. STreamout --> Input
  801. Streamin <-- Output
  802. Return value is the process ID of the process being spawned, or -1 in case of failure.
  803. }
  804. var
  805. pipi,
  806. pipo : text;
  807. pid : cint;
  808. pl : ^cint;
  809. begin
  810. AssignStream:=-1;
  811. if fpAccess(prog,X_OK)<>0 then
  812. exit(-1);
  813. if AssignPipe(streamin,pipo)=-1 Then
  814. exit(-1);
  815. if AssignPipe(pipi,streamout)=-1 Then
  816. begin
  817. close(streamin);
  818. close(pipo);
  819. exit(-1);
  820. end;
  821. pid:=fpfork;
  822. if pid=-1 then
  823. begin
  824. close(pipi);
  825. close(pipo);
  826. close (streamin);
  827. close (streamout);
  828. exit;
  829. end;
  830. if pid=0 then
  831. begin
  832. { We're in the child }
  833. { Close what we don't need }
  834. close(streamout);
  835. close(streamin);
  836. if fpdup2(pipi,input)=-1 Then
  837. halt(127);
  838. close(pipi);
  839. If fpdup2(pipo,output)=-1 Then
  840. halt (127);
  841. close(pipo);
  842. fpExecl(Prog,args);
  843. halt(127);
  844. end
  845. else
  846. begin
  847. { we're in the parent}
  848. close(pipo);
  849. close(pipi);
  850. {Save the process ID - needed when closing }
  851. pl:=pcint(@textrec(StreamIn).userdata[2]);
  852. { avoid alignment error on sparc }
  853. move(pid,pl^,sizeof(pid));
  854. textrec(StreamIn).closefunc:=@PCloseText;
  855. {Save the process ID - needed when closing }
  856. pl:=pcint(@textrec(StreamOut).userdata[2]);
  857. { avoid alignment error on sparc }
  858. move(pid,pl^,sizeof(pid));
  859. textrec(StreamOut).closefunc:=@PCloseText;
  860. AssignStream:=Pid;
  861. end;
  862. end;
  863. Function AssignStream(Var StreamIn,Streamout,streamerr:text;Const Prog:ansiString;const args : array of ansistring) : cint;
  864. {
  865. Starts the program in 'prog' and makes its input, output and error output the
  866. other end of three pipes, which are the stdin, stdout and stderr of a program
  867. specified in 'prog'.
  868. StreamOut can be used to write to the program, StreamIn can be used to read
  869. the output of the program, StreamErr reads the error output of the program.
  870. See the following diagram :
  871. Parent Child
  872. StreamOut --> StdIn (input)
  873. StreamIn <-- StdOut (output)
  874. StreamErr <-- StdErr (error output)
  875. }
  876. var
  877. PipeIn, PipeOut, PipeErr: text;
  878. pid: cint;
  879. pl: ^cint;
  880. begin
  881. AssignStream := -1;
  882. if fpAccess(prog,X_OK)<>0 then
  883. exit(-1);
  884. // Assign pipes
  885. if AssignPipe(StreamIn, PipeOut)=-1 Then
  886. Exit(-1);
  887. If AssignPipe(StreamErr, PipeErr)=-1 Then
  888. begin
  889. Close(StreamIn);
  890. Close(PipeOut);
  891. exit(-1);
  892. end;
  893. if AssignPipe(PipeIn, StreamOut)=-1 Then
  894. begin
  895. Close(StreamIn);
  896. Close(PipeOut);
  897. Close(StreamErr);
  898. Close(PipeErr);
  899. exit(-1);
  900. end;
  901. // Fork
  902. pid := fpFork;
  903. if pid=-1 then begin
  904. Close(StreamIn);
  905. Close(PipeOut);
  906. Close(StreamErr);
  907. Close(PipeErr);
  908. Close(PipeIn);
  909. Close(StreamOut);
  910. exit(-1);
  911. end;
  912. if pid = 0 then begin
  913. // *** We are in the child ***
  914. // Close what we don not need
  915. Close(StreamOut);
  916. Close(StreamIn);
  917. Close(StreamErr);
  918. // Connect pipes
  919. if fpdup2(PipeIn, Input)=-1 Then
  920. Halt(127);
  921. Close(PipeIn);
  922. if fpdup2(PipeOut, Output)=-1 Then
  923. Halt(127);
  924. Close(PipeOut);
  925. if fpdup2(PipeErr, StdErr)=-1 Then
  926. Halt(127);
  927. Close(PipeErr);
  928. // Execute program
  929. fpExecl(Prog,args);
  930. Halt(127);
  931. end else begin
  932. // *** We are in the parent ***
  933. Close(PipeErr);
  934. Close(PipeOut);
  935. Close(PipeIn);
  936. // Save the process ID - needed when closing
  937. pl := pcint(@TextRec(StreamIn).userdata[2]);
  938. { avoid alignment error on sparc }
  939. move(pid,pl^,sizeof(pid));
  940. TextRec(StreamIn).closefunc := @PCloseText;
  941. // Save the process ID - needed when closing
  942. pl := pcint(@TextRec(StreamOut).userdata[2]);
  943. { avoid alignment error on sparc }
  944. move(pid,pl^,sizeof(pid));
  945. TextRec(StreamOut).closefunc := @PCloseText;
  946. // Save the process ID - needed when closing
  947. pl := pcint(@TextRec(StreamErr).userdata[2]);
  948. { avoid alignment error on sparc }
  949. move(pid,pl^,sizeof(pid));
  950. TextRec(StreamErr).closefunc := @PCloseText;
  951. AssignStream := pid;
  952. end;
  953. end;
  954. {******************************************************************************
  955. General information calls
  956. ******************************************************************************}
  957. {$if defined(Linux)}
  958. Function GetDomainName:String; { linux only!}
  959. // domainname is a glibc extension.
  960. {
  961. Get machines domain name. Returns empty string if not set.
  962. }
  963. Var
  964. Sysn : utsname;
  965. begin
  966. If fpUname(sysn)<>0 then
  967. getdomainname:=''
  968. else
  969. getdomainname:=strpas(@Sysn.domain[0]);
  970. end;
  971. {$endif}
  972. {$ifdef sunos}
  973. { sunos doesn't support GetDomainName, see also
  974. http://www.sun.com/software/solaris/programs/abi/appcert_faq.xml#q18
  975. }
  976. Function GetDomainName:String;
  977. begin
  978. GetDomainName:='';
  979. end;
  980. {$endif sunos}
  981. {$ifdef android}
  982. { android doesn't seem to implement GetDomainName
  983. }
  984. Function GetDomainName:String;
  985. begin
  986. GetDomainName:='';
  987. end;
  988. {$endif}
  989. {$if defined(BSD) or defined(aix)}
  990. function intGetDomainName(Name:PChar; NameLen:Cint):cint;
  991. {$ifndef FPC_USE_LIBC}
  992. external name 'FPC_SYSC_GETDOMAINNAME';
  993. {$else FPC_USE_LIBC}
  994. cdecl; external clib name 'getdomainname';
  995. {$endif FPC_USE_LIBC}
  996. Function GetDomainName:String; { linux only!}
  997. // domainname is a glibc extension.
  998. {
  999. Get machines domain name. Returns empty string if not set.
  1000. }
  1001. begin
  1002. if intGetDomainName(@getdomainname[1],255)=-1 then
  1003. getdomainname:=''
  1004. else
  1005. getdomainname[0]:=chr(strlen(@getdomainname[1]));
  1006. end;
  1007. {$endif}
  1008. Function GetHostName:String;
  1009. {
  1010. Get machines name. Returns empty string if not set.
  1011. }
  1012. Var
  1013. Sysn : utsname;
  1014. begin
  1015. If fpuname(sysn)=-1 then
  1016. gethostname:=''
  1017. else
  1018. gethostname:=strpas(@Sysn.nodename[0]);
  1019. end;
  1020. {******************************************************************************
  1021. Utility calls
  1022. ******************************************************************************}
  1023. Function FSearch(const path:RawByteString;dirlist:RawByteString;CurrentDirStrategy:TFSearchOption):RawByteString;
  1024. {
  1025. Searches for a file 'path' in the list of direcories in 'dirlist'.
  1026. returns an empty string if not found. Wildcards are NOT allowed.
  1027. If dirlist is empty, it is set to '.'
  1028. This function tries to make FSearch use ansistrings, and decrease
  1029. stringhandling overhead at the same time.
  1030. }
  1031. Var
  1032. mypath,
  1033. mydir,NewDir : RawByteString;
  1034. p1 : cint;
  1035. Info : Stat;
  1036. i,j : cint;
  1037. p : pchar;
  1038. Begin
  1039. SetCodePage(dirlist,DefaultFileSystemCodePage);
  1040. if CurrentDirStrategy=CurrentDirectoryFirst Then
  1041. Dirlist:=ToSingleByteFileSystemEncodedFileName('.:')+dirlist {Make sure current dir is first to be searched.}
  1042. else if CurrentDirStrategy=CurrentDirectoryLast Then
  1043. Dirlist:=dirlist+ToSingleByteFileSystemEncodedFileName('.:'); {Make sure current dir is last to be searched.}
  1044. {Replace ':' and ';' with #0}
  1045. for p1:=1 to length(dirlist) do
  1046. if (dirlist[p1]=':') or (dirlist[p1]=';') then
  1047. dirlist[p1]:=#0;
  1048. {Check for WildCards}
  1049. If (Pos('?',Path) <> 0) or (Pos('*',Path) <> 0) Then
  1050. FSearch:='' {No wildcards allowed in these things.}
  1051. Else
  1052. Begin
  1053. mypath:=ToSingleByteFileSystemEncodedFileName(path);
  1054. p:=pchar(dirlist);
  1055. i:=length(dirlist);
  1056. j:=1;
  1057. Repeat
  1058. mydir:=RawByteString(p);
  1059. if (length(mydir)>0) and (mydir[length(mydir)]<>'/') then
  1060. begin
  1061. { concatenate character without influencing code page }
  1062. setlength(mydir,length(mydir)+1);
  1063. mydir[length(mydir)]:='/';
  1064. end;
  1065. NewDir:=mydir+mypath;
  1066. if (FpStat(NewDir,Info)>=0) and
  1067. (not fpS_ISDIR(Info.st_Mode)) then
  1068. Begin
  1069. If Pos('./',NewDir)=1 Then
  1070. Delete(NewDir,1,2);
  1071. {DOS strips off an initial .\}
  1072. End
  1073. Else
  1074. NewDir:='';
  1075. while (j<=i) and (p^<>#0) do begin inc(j); inc(p); end;
  1076. if p^=#0 then inc(p);
  1077. Until (j>=i) or (Length(NewDir) > 0);
  1078. FSearch:=NewDir;
  1079. SetCodePage(FSearch,DefaultRTLFileSystemCodePage);
  1080. End;
  1081. End;
  1082. Function FSearch(const path:RawByteString;dirlist:RawByteString):RawByteString;
  1083. Begin
  1084. FSearch:=FSearch(path,dirlist,CurrentDirectoryFirst);
  1085. End;
  1086. function FSearch(const path: UnicodeString; dirlist: UnicodeString; CurrentDirStrategy: TFSearchOption): UnicodeString;
  1087. begin
  1088. FSearch:=FSearch(ToSingleByteFileSystemEncodedFileName(path),ToSingleByteFileSystemEncodedFileName(dirlist),CurrentDirStrategy);
  1089. end;
  1090. function FSearch(const path: UnicodeString; dirlist: UnicodeString): UnicodeString;
  1091. begin
  1092. FSearch:=FSearch(ToSingleByteFileSystemEncodedFileName(path),ToSingleByteFileSystemEncodedFileName(dirlist),CurrentDirectoryFirst);
  1093. end;
  1094. {$ifdef android}
  1095. {$I unixandroid.inc}
  1096. {$endif android}
  1097. Initialization
  1098. {$IFNDEF DONT_READ_TIMEZONE}
  1099. InitLocalTime;
  1100. {$endif}
  1101. {$ifdef android}
  1102. InitLocalTime;
  1103. {$endif android}
  1104. finalization
  1105. {$IFNDEF DONT_READ_TIMEZONE}
  1106. DoneLocalTime;
  1107. {$endif}
  1108. End.