unix.pp 43 KB

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