unix.pp 41 KB

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