unix.pp 46 KB

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