unix.pp 43 KB

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