unix.pp 45 KB

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