12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769 |
- {
- $Id$
- This file is part of the Free Pascal run time library.
- Copyright (c) 1999-2000 by Michael Van Canneyt,
- BSD parts (c) 2000 by Marco van de Voort
- members of the Free Pascal development team.
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY;without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- **********************************************************************}
- Unit Unix;
- Interface
- Uses UnixUtil,BaseUnix;
- {// i ostypes.inc}
- { Get Types and Constants }
- {$i sysconst.inc}
- {$i systypes.inc}
- { Get System call numbers and error-numbers}
- {$i sysnr.inc}
- {$i errno.inc}
- {$I signal.inc}
- {$i ostypes.inc}
- var
- LinuxError : Longint;
- {********************
- Process
- ********************}
- const
- { For getting/setting priority }
- Prio_Process = 0;
- Prio_PGrp = 1;
- Prio_User = 2;
- {$ifdef Solaris}
- WNOHANG = $100;
- WUNTRACED = $4;
- {$ELSE}
- WNOHANG = $1;
- WUNTRACED = $2;
- __WCLONE = $80000000;
- {$ENDIF}
- {********************
- File
- ********************}
- Const
- P_IN = 1;
- P_OUT = 2;
- Const
- LOCK_SH = 1;
- LOCK_EX = 2;
- LOCK_UN = 8;
- LOCK_NB = 4;
- Type
- Tpipe = array[1..2] of longint;
- pglob = ^tglob;
- tglob = record
- name : pchar;
- next : pglob;
- end;
- const
- { For File control mechanism }
- F_GetFd = 1;
- F_SetFd = 2;
- F_GetFl = 3;
- F_SetFl = 4;
- {$ifdef Solaris}
- F_DupFd = 0;
- F_Dup2Fd = 9;
- F_GetOwn = 23;
- F_SetOwn = 24;
- F_GetLk = 14;
- F_SetLk = 6;
- F_SetLkW = 7;
- F_FreeSp = 11;
- {$else}
- F_GetLk = 5;
- F_SetLk = 6;
- F_SetLkW = 7;
- F_SetOwn = 8;
- F_GetOwn = 9;
- {$endif}
- {********************
- IOCtl(TermIOS)
- ********************}
- {Is too freebsd/Linux specific}
- {$I termios.inc}
- {******************************************************************************
- Procedure/Functions
- ******************************************************************************}
- {**************************
- Time/Date Handling
- ***************************}
- var
- tzdaylight : boolean;
- tzname : array[boolean] of pchar;
- { timezone support }
- procedure GetLocalTimezone(timer:longint;var leap_correct,leap_hit:longint);
- procedure GetLocalTimezone(timer:longint);
- procedure ReadTimezoneFile(fn:string);
- function GetTimezoneFile:string;
- Function GetEpochTime: longint;
- procedure GetTime(var hour,min,sec,msec,usec:word);
- procedure GetTime(var hour,min,sec,sec100:word);
- procedure GetTime(var hour,min,sec:word);
- Procedure GetDate(Var Year,Month,Day:Word);
- Procedure GetDateTime(Var Year,Month,Day,hour,minute,second:Word);
- function SetTime(Hour,Min,Sec:word) : Boolean;
- function SetDate(Year,Month,Day:Word) : Boolean;
- function SetDateTime(Year,Month,Day,hour,minute,second:Word) : Boolean;
- {**************************
- Process Handling
- ***************************}
- function CreateShellArgV(const prog:string):ppchar;
- function CreateShellArgV(const prog:Ansistring):ppchar;
- //Procedure Execve(Path: pathstr;args:ppchar;ep:ppchar);
- //Procedure Execve(Path: AnsiString;args:ppchar;ep:ppchar);
- //Procedure Execve(path: pchar;args:ppchar;ep:ppchar);
- Procedure Execv(const path:pathstr;args:ppchar);
- Procedure Execv(const path: AnsiString;args:ppchar);
- Procedure Execvp(Path: Pathstr;Args:ppchar;Ep:ppchar);
- Procedure Execvp(Path: AnsiString; Args:ppchar;Ep:ppchar);
- Procedure Execl(const Todo: String);
- Procedure Execl(const Todo: Ansistring);
- Procedure Execle(Todo: String;Ep:ppchar);
- Procedure Execle(Todo: AnsiString;Ep:ppchar);
- Procedure Execlp(Todo: string;Ep:ppchar);
- Procedure Execlp(Todo: Ansistring;Ep:ppchar);
- Function Shell(const Command:String):Longint;
- Function Shell(const Command:AnsiString):Longint;
- {Clone for FreeBSD is copied from the LinuxThread port, and rfork based}
- function Clone(func:TCloneFunc;sp:pointer;flags:longint;args:pointer):longint;
- 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}
- Function WIFSTOPPED(Status: Integer): Boolean;
- Function W_EXITCODE(ReturnCode, Signal: Integer): Integer;
- Function W_STOPCODE(Signal: Integer): Integer;
- {**************************
- File Handling
- ***************************}
- Function fdFlush (fd : Longint) : Boolean;
- Function Flock (fd,mode : longint) : boolean;
- Function Flock (var T : text;mode : longint) : boolean;
- Function Flock (var F : File;mode : longint) : boolean;
- Function StatFS(Path:Pathstr;Var Info:tstatfs):Boolean;
- Function StatFS(Fd: Longint;Var Info:tstatfs):Boolean;
- Function SelectText(var T:Text;TimeOut :PTimeVal):Longint;
- Function SelectText(var T:Text;TimeOut :Longint):Longint;
- {**************************
- Directory Handling
- ***************************}
- procedure SeekDir(p:pdir;off:longint);
- function TellDir(p:pdir):longint;
- {**************************
- Pipe/Fifo/Stream
- ***************************}
- Function AssignPipe(var pipe_in,pipe_out:longint):boolean;
- Function AssignPipe(var pipe_in,pipe_out:text):boolean;
- Function AssignPipe(var pipe_in,pipe_out:file):boolean;
- Function PClose(Var F:text) : longint;
- Function PClose(Var F:file) : longint;
- Procedure POpen(var F:text;const Prog:String;rw:char);
- Procedure POpen(var F:file;const Prog:String;rw:char);
- function AssignStream(Var StreamIn,Streamout:text;Const Prog:String) : longint;
- function AssignStream(var StreamIn, StreamOut, StreamErr: Text; const prog: String): LongInt;
- {$ifndef BSD}
- Function GetDomainName:String;
- Function GetHostName:String;
- {$endif}
- {**************************
- IOCtl/Termios Functions
- ***************************}
- Function TCGetAttr(fd:longint;var tios:TermIOS):boolean;
- Function TCSetAttr(fd:longint;OptAct:longint;const tios:TermIOS):boolean;
- Procedure CFSetISpeed(var tios:TermIOS;speed:Cardinal);
- Procedure CFSetOSpeed(var tios:TermIOS;speed:Cardinal);
- Procedure CFMakeRaw(var tios:TermIOS);
- Function TCSendBreak(fd,duration:longint):boolean;
- Function TCSetPGrp(fd,id:longint):boolean;
- Function TCGetPGrp(fd:longint;var id:longint):boolean;
- Function TCFlush(fd,qsel:longint):boolean;
- Function TCDrain(fd:longint):boolean;
- Function TCFlow(fd,act:longint):boolean;
- Function IsATTY(Handle:Longint):Boolean;
- Function IsATTY(f:text):Boolean;
- function TTYname(Handle:Longint):string;
- function TTYname(var F:Text):string;
- {**************************
- Memory functions
- ***************************}
- const
- PROT_READ = $1; { page can be read }
- PROT_WRITE = $2; { page can be written }
- PROT_EXEC = $4; { page can be executed }
- PROT_NONE = $0; { page can not be accessed }
- MAP_SHARED = $1; { Share changes }
- // MAP_PRIVATE = $2; { Changes are private }
- MAP_TYPE = $f; { Mask for type of mapping }
- MAP_FIXED = $10; { Interpret addr exactly }
- // MAP_ANONYMOUS = $20; { don't use a file }
- MAP_GROWSDOWN = $100; { stack-like segment }
- MAP_DENYWRITE = $800; { ETXTBSY }
- MAP_EXECUTABLE = $1000; { mark it as an executable }
- MAP_LOCKED = $2000; { pages are locked }
- MAP_NORESERVE = $4000; { don't check for reservations }
- {**************************
- Utility functions
- ***************************}
- Function Octal(l:longint):longint;
- Function FExpand(Const Path: PathStr):PathStr;
- Function FSearch(const path:pathstr;dirlist:string):pathstr;
- Function Glob(Const path:pathstr):pglob;
- Procedure Globfree(var p:pglob);
- {Filedescriptorsets}
- {Stat.Mode Types}
- {******************************************************************************
- Implementation
- ******************************************************************************}
- {$i unxsysch.inc}
- Implementation
- Uses Strings;
- {$i syscallh.inc}
- {$i unxsysc.inc}
- {$i ossysch.inc}
- { Get the definitions of textrec and filerec }
- {$i textrec.inc}
- {$i filerec.inc}
- { Raw System calls are in Syscalls.inc}
- {$i syscalls.inc}
- {$i unixsysc.inc} {Syscalls only used in unit Unix/Linux}
- Function getenv(name:string):Pchar; external name 'FPC_SYSC_FPGETENV';
- {******************************************************************************
- Process related calls
- ******************************************************************************}
- { Most calls of WaitPID do not handle the result correctly, this funktion treats errors more correctly }
- 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}
- var r,s : LongInt;
- begin
- repeat
- s:=$7F00;
- r:=fpWaitPid(Pid,s,0);
- until (r<>-1) or (LinuxError<>ESysEINTR);
- if (r=-1) or (r=0) then // 0 is not a valid return and should never occur (it means status invalid when using WNOHANG)
- WaitProcess:=-1 // return -1 to indicate an error
- else
- begin
- {$ifndef Solaris}
- { at least correct for Linux and Darwin (JM) }
- if (s and $7F)=0 then // Only this is a valid returncode
- {$else}
- if (s and $FF)=0 then // Only this is a valid returncode
- {$endif}
- WaitProcess:=s shr 8
- else if (s>0) then // Until now there is not use of the highest bit , but check this for the future
- WaitProcess:=-s // normal case
- else
- WaitProcess:=s; // s<0 should not occur, but wie return also a negativ value
- end;
- end;
- function InternalCreateShellArgV(cmd:pChar; len:longint):ppchar;
- {
- Create an argv which executes a command in a shell using /bin/sh -c
- }
- const Shell = '/bin/sh'#0'-c'#0;
- var
- pp,p : ppchar;
- // temp : string; !! Never pass a local var back!!
- begin
- getmem(pp,4*4);
- p:=pp;
- p^:=@Shell[1];
- inc(p);
- p^:=@Shell[9];
- inc(p);
- getmem(p^,len+1);
- move(cmd^,p^^,len);
- pchar(p^)[len]:=#0;
- inc(p);
- p^:=Nil;
- InternalCreateShellArgV:=pp;
- end;
- function CreateShellArgV(const prog:string):ppchar;
- begin
- CreateShellArgV:=InternalCreateShellArgV(@prog[1],length(prog));
- end;
- function CreateShellArgV(const prog:Ansistring):ppchar;
- {
- Create an argv which executes a command in a shell using /bin/sh -c
- using a AnsiString;
- }
- begin
- CreateShellArgV:=InternalCreateShellArgV(@prog[1],length(prog)); // if ppc works like delphi this also work when @prog[1] is invalid (len=0)
- end;
- procedure FreeShellArgV(p:ppchar);
- begin
- if (p<>nil) then begin
- freemem(p[2]);
- freemem(p);
- end;
- end;
- Procedure Execv(const path: AnsiString;args:ppchar);
- {
- Overloaded ansistring version.
- }
- begin
- fpExecVe(Path,Args,envp)
- end;
- Procedure Execvp(Path: AnsiString; Args:ppchar;Ep:ppchar);
- {
- Overloaded ansistring version
- }
- var
- thepath : Ansistring;
- begin
- if path[1]<>'/' then
- begin
- Thepath:=strpas(fpgetenv('PATH'));
- if thepath='' then
- thepath:='.';
- Path:=FSearch(path,thepath)
- end
- else
- Path:='';
- if Path='' then
- linuxerror:=ESysEnoent
- else
- fpExecve(Path,args,ep);{On error linuxerror will get set there}
- end;
- Procedure Execv(const path:pathstr;args:ppchar);
- {
- Replaces the current program by the program specified in path,
- arguments in args are passed to Execve.
- the current environment is passed on.
- }
- begin
- fpExecve(path,args,envp); {On error linuxerror will get set there}
- end;
- Procedure Execvp(Path:Pathstr;Args:ppchar;Ep:ppchar);
- {
- This does the same as Execve, only it searches the PATH environment
- for the place of the Executable, except when Path starts with a slash.
- if the PATH environment variable is unavailable, the path is set to '.'
- }
- var
- thepath : string;
- begin
- if path[1]<>'/' then
- begin
- Thepath:=strpas(fpgetenv('PATH'));
- if thepath='' then
- thepath:='.';
- Path:=FSearch(path,thepath)
- end
- else
- Path:='';
- if Path='' then
- linuxerror:=ESysEnoent
- else
- fpExecve(Path,args,ep);{On error linuxerror will get set there}
- end;
- Procedure Execle(Todo:string;Ep:ppchar);
- {
- This procedure takes the string 'Todo', parses it for command and
- command options, and Executes the command with the given options.
- The string 'Todo' shoud be of the form 'command options', options
- separated by commas.
- the PATH environment is not searched for 'command'.
- The specified environment(in 'ep') is passed on to command
- }
- var
- p : ppchar;
- begin
- p:=StringToPPChar(ToDo);
- if (p=nil) or (p^=nil) then
- exit;
- fpExecVE(p^,p,EP);
- end;
- Procedure Execle(Todo:AnsiString;Ep:ppchar);
- {
- This procedure takes the string 'Todo', parses it for command and
- command options, and Executes the command with the given options.
- The string 'Todo' shoud be of the form 'command options', options
- separated by commas.
- the PATH environment is not searched for 'command'.
- The specified environment(in 'ep') is passed on to command
- }
- var
- p : ppchar;
- begin
- p:=StringToPPChar(ToDo);
- if (p=nil) or (p^=nil) then
- exit;
- fpExecVE(p^,p,EP);
- end;
- Procedure Execl(const Todo:string);
- {
- This procedure takes the string 'Todo', parses it for command and
- command options, and Executes the command with the given options.
- The string 'Todo' shoud be of the form 'command options', options
- separated by commas.
- the PATH environment is not searched for 'command'.
- The current environment is passed on to command
- }
- begin
- ExecLE(ToDo,EnvP);
- end;
- Procedure Execlp(Todo:string;Ep:ppchar);
- {
- This procedure takes the string 'Todo', parses it for command and
- command options, and Executes the command with the given options.
- The string 'Todo' shoud be of the form 'command options', options
- separated by commas.
- the PATH environment is searched for 'command'.
- The specified environment (in 'ep') is passed on to command
- }
- var
- p : ppchar;
- begin
- p:=StringToPPchar(todo);
- if (p=nil) or (p^=nil) then
- exit;
- ExecVP(StrPas(p^),p,EP);
- end;
- Procedure Execlp(Todo: Ansistring;Ep:ppchar);
- {
- Overloaded ansistring version.
- }
- var
- p : ppchar;
- begin
- p:=StringToPPchar(todo);
- if (p=nil) or (p^=nil) then
- exit;
- ExecVP(StrPas(p^),p,EP);
- end;
- Function Shell(const Command:String):Longint;
- {
- Executes the shell, and passes it the string Command. (Through /bin/sh -c)
- The current environment is passed to the shell.
- It waits for the shell to exit, and returns its exit status.
- If the Exec call failed exit status 127 is reported.
- }
- { Changed the structure:
- - the previous version returns an undefinied value if fork fails
- - it returns the status of Waitpid instead of the Process returnvalue (see the doc to Shell)
- - it uses exit(127) not ExitProc (The Result in pp386: going on Compiling in 2 processes!)
- - ShellArgs are now released
- - The Old CreateShellArg gives back pointers to a local var
- }
- var
- p : ppchar;
- pid : longint;
- begin
- p:=CreateShellArgv(command);
- pid:=fpfork;
- if pid=0 then // We are in the Child
- begin
- {This is the child.}
- fpExecve(p^,p,envp);
- fpExit(127); // was Exit(127)
- end
- else if (pid<>-1) then // Successfull started
- Shell:=WaitProcess(pid) {Linuxerror is set there}
- else // no success
- Shell:=-1; // indicate an error
- FreeShellArgV(p);
- end;
- Function Shell(const Command:AnsiString):Longint;
- {
- AnsiString version of Shell
- }
- var
- p : ppchar;
- pid : longint;
- begin { Changes as above }
- p:=CreateShellArgv(command);
- pid:=fpfork;
- if pid=0 then // We are in the Child
- begin
- fpExecve(p^,p,envp);
- fpExit(127); // was exit(127)!! We must exit the Process, not the function
- end
- else if (pid<>-1) then // Successfull started
- Shell:=WaitProcess(pid) {Linuxerror is set there}
- else // no success
- Shell:=-1;
- FreeShellArgV(p);
- end;
- Function WIFSTOPPED(Status: Integer): Boolean;
- begin
- WIFSTOPPED:=((Status and $FF)=$7F);
- end;
- Function W_EXITCODE(ReturnCode, Signal: Integer): Integer;
- begin
- W_EXITCODE:=(ReturnCode shl 8) or Signal;
- end;
- Function W_STOPCODE(Signal: Integer): Integer;
- begin
- W_STOPCODE:=(Signal shl 8) or $7F;
- end;
- {******************************************************************************
- Date and Time related calls
- ******************************************************************************}
- Function GetEpochTime: longint;
- {
- Get the number of seconds since 00:00, January 1 1970, GMT
- the time NOT corrected any way
- }
- begin
- GetEpochTime:=fptime;
- end;
- procedure GetTime(var hour,min,sec,msec,usec:word);
- {
- Gets the current time, adjusted to local time
- }
- var
- year,day,month:Word;
- tz:timeval;
- begin
- fpgettimeofday(@tz,nil);
- EpochToLocal(tz.tv_sec,year,month,day,hour,min,sec);
- msec:=tz.tv_usec div 1000;
- usec:=tz.tv_usec mod 1000;
- end;
- procedure GetTime(var hour,min,sec,sec100:word);
- {
- Gets the current time, adjusted to local time
- }
- var
- usec : word;
- begin
- gettime(hour,min,sec,sec100,usec);
- sec100:=sec100 div 10;
- end;
- Procedure GetTime(Var Hour,Min,Sec:Word);
- {
- Gets the current time, adjusted to local time
- }
- var
- msec,usec : Word;
- Begin
- gettime(hour,min,sec,msec,usec);
- End;
- Procedure GetDate(Var Year,Month,Day:Word);
- {
- Gets the current date, adjusted to local time
- }
- var
- hour,minute,second : word;
- Begin
- EpochToLocal(fptime,year,month,day,hour,minute,second);
- End;
- Procedure GetDateTime(Var Year,Month,Day,hour,minute,second:Word);
- {
- Gets the current date, adjusted to local time
- }
- Begin
- EpochToLocal(fptime,year,month,day,hour,minute,second);
- End;
- {$ifndef BSD}
- {$ifdef linux}
- Function stime (t : longint) : Boolean;
- var
- sr : Syscallregs;
- begin
- sr.reg2:=longint(@t);
- SysCall(Syscall_nr_stime,sr);
- linuxerror:=fpgeterrno;;
- stime:=linuxerror=0;
- end;
- {$endif}
- {$endif}
- {$ifdef BSD}
- Function stime (t : longint) : Boolean;
- begin
- end;
- {$endif}
- Function SetTime(Hour,Min,Sec:word) : boolean;
- var
- Year, Month, Day : Word;
- begin
- GetDate (Year, Month, Day);
- SetTime:=stime ( LocalToEpoch ( Year, Month, Day, Hour, Min, Sec ) );
- end;
- Function SetDate(Year,Month,Day:Word) : boolean;
- var
- Hour, Minute, Second, Sec100 : Word;
- begin
- GetTime ( Hour, Minute, Second, Sec100 );
- SetDate:=stime ( LocalToEpoch ( Year, Month, Day, Hour, Minute, Second ) );
- end;
- Function SetDateTime(Year,Month,Day,hour,minute,second:Word) : Boolean;
- begin
- SetDateTime:=stime ( LocalToEpoch ( Year, Month, Day, Hour, Minute, Second ) );
- end;
- { Include timezone handling routines which use /usr/share/timezone info }
- {$i timezone.inc}
- {******************************************************************************
- FileSystem calls
- ******************************************************************************}
- Procedure Execl(const Todo:Ansistring);
- {
- Overloaded AnsiString Version of ExecL.
- }
- begin
- ExecLE(ToDo,EnvP);
- end;
- Function Flock (var T : text;mode : longint) : boolean;
- begin
- Flock:=Flock(TextRec(T).Handle,mode);
- end;
- Function Flock (var F : File;mode : longint) : boolean;
- begin
- Flock:=Flock(FileRec(F).Handle,mode);
- end;
- Function SelectText(var T:Text;TimeOut :PTimeval):Longint;
- Var
- F:TfdSet;
- begin
- if textrec(t).mode=fmclosed then
- begin
- LinuxError:=ESysEBADF;
- exit(-1);
- end;
- FpFD_ZERO(f);
- fpFD_SET(textrec(T).handle,f);
- if textrec(T).mode=fminput then
- SelectText:=fpselect(textrec(T).handle+1,@f,nil,nil,TimeOut)
- else
- SelectText:=fpselect(textrec(T).handle+1,nil,@f,nil,TimeOut);
- end;
- Function SelectText(var T:Text;TimeOut :Longint):Longint;
- var
- p : PTimeVal;
- tv : TimeVal;
- begin
- if TimeOut=-1 then
- p:=nil
- else
- begin
- tv.tv_Sec:=Timeout div 1000;
- tv.tv_Usec:=(Timeout mod 1000)*1000;
- p:=@tv;
- end;
- SelectText:=SelectText(T,p);
- end;
- {******************************************************************************
- Directory
- ******************************************************************************}
- procedure SeekDir(p:pdir;off:longint);
- begin
- if p=nil then
- begin
- fpseterrno(ESysEBADF);
- exit;
- end;
- {$ifndef bsd}
- p^.dd_nextoff:=fplseek(p^.dd_fd,off,seek_set);
- {$endif}
- p^.dd_size:=0;
- p^.dd_loc:=0;
- end;
- function TellDir(p:pdir):longint;
- begin
- if p=nil then
- begin
- fpseterrno(ESysEBADF);
- telldir:=-1;
- exit;
- end;
- telldir:=fplseek(p^.dd_fd,0,seek_cur)
- { We could try to use the nextoff field here, but on my 1.2.13
- kernel, this gives nothing... This may have to do with
- the readdir implementation of libc... I also didn't find any trace of
- the field in the kernel code itself, So I suspect it is an artifact of libc.
- Michael. }
- end;
- {******************************************************************************
- Pipes/Fifo
- ******************************************************************************}
- Procedure OpenPipe(var F:Text);
- begin
- case textrec(f).mode of
- fmoutput :
- if textrec(f).userdata[1]<>P_OUT then
- textrec(f).mode:=fmclosed;
- fminput :
- if textrec(f).userdata[1]<>P_IN then
- textrec(f).mode:=fmclosed;
- else
- textrec(f).mode:=fmclosed;
- end;
- end;
- Procedure IOPipe(var F:text);
- begin
- case textrec(f).mode of
- fmoutput :
- begin
- { first check if we need something to write, else we may
- get a SigPipe when Close() is called (PFV) }
- if textrec(f).bufpos>0 then
- fpwrite(textrec(f).handle,pchar(textrec(f).bufptr),textrec(f).bufpos);
- end;
- fminput :
- textrec(f).bufend:=fpread(textrec(f).handle,pchar(textrec(f).bufptr),textrec(f).bufsize);
- end;
- textrec(f).bufpos:=0;
- end;
- Procedure FlushPipe(var F:Text);
- begin
- if (textrec(f).mode=fmoutput) and (textrec(f).bufpos<>0) then
- IOPipe(f);
- textrec(f).bufpos:=0;
- end;
- Procedure ClosePipe(var F:text);
- begin
- textrec(f).mode:=fmclosed;
- fpclose(textrec(f).handle);
- end;
- Function AssignPipe(var pipe_in,pipe_out:text):boolean;
- {
- Sets up a pair of file variables, which act as a pipe. The first one can
- be read from, the second one can be written to.
- If the operation was unsuccesful, linuxerror is set.
- }
- var
- f_in,f_out : longint;
- begin
- if not AssignPipe(f_in,f_out) then
- begin
- AssignPipe:=false;
- exit;
- end;
- { Set up input }
- Assign(Pipe_in,'');
- Textrec(Pipe_in).Handle:=f_in;
- Textrec(Pipe_in).Mode:=fmInput;
- Textrec(Pipe_in).userdata[1]:=P_IN;
- TextRec(Pipe_in).OpenFunc:=@OpenPipe;
- TextRec(Pipe_in).InOutFunc:=@IOPipe;
- TextRec(Pipe_in).FlushFunc:=@FlushPipe;
- TextRec(Pipe_in).CloseFunc:=@ClosePipe;
- { Set up output }
- Assign(Pipe_out,'');
- Textrec(Pipe_out).Handle:=f_out;
- Textrec(Pipe_out).Mode:=fmOutput;
- Textrec(Pipe_out).userdata[1]:=P_OUT;
- TextRec(Pipe_out).OpenFunc:=@OpenPipe;
- TextRec(Pipe_out).InOutFunc:=@IOPipe;
- TextRec(Pipe_out).FlushFunc:=@FlushPipe;
- TextRec(Pipe_out).CloseFunc:=@ClosePipe;
- AssignPipe:=true;
- end;
- Function AssignPipe(var pipe_in,pipe_out:file):boolean;
- {
- Sets up a pair of file variables, which act as a pipe. The first one can
- be read from, the second one can be written to.
- If the operation was unsuccesful, linuxerror is set.
- }
- var
- f_in,f_out : longint;
- begin
- if not AssignPipe(f_in,f_out) then
- begin
- AssignPipe:=false;
- exit;
- end;
- { Set up input }
- Assign(Pipe_in,'');
- Filerec(Pipe_in).Handle:=f_in;
- Filerec(Pipe_in).Mode:=fmInput;
- Filerec(Pipe_in).recsize:=1;
- Filerec(Pipe_in).userdata[1]:=P_IN;
- { Set up output }
- Assign(Pipe_out,'');
- Filerec(Pipe_out).Handle:=f_out;
- Filerec(Pipe_out).Mode:=fmoutput;
- Filerec(Pipe_out).recsize:=1;
- Filerec(Pipe_out).userdata[1]:=P_OUT;
- AssignPipe:=true;
- end;
- Procedure PCloseText(Var F:text);
- {
- May not use @PClose due overloading
- }
- begin
- PClose(f);
- end;
- Procedure POpen(var F:text;const Prog:String;rw:char);
- {
- Starts the program in 'Prog' and makes it's input or out put the
- other end of a pipe. If rw is 'w' or 'W', then whatever is written to
- F, will be read from stdin by the program in 'Prog'. The inverse is true
- for 'r' or 'R' : whatever the program in 'Prog' writes to stdout, can be
- read from 'f'.
- }
- var
- pipi,
- pipo : text;
- pid : longint;
- pl : ^longint;
- pp : ppchar;
- begin
- LinuxError:=0;
- rw:=upcase(rw);
- if not (rw in ['R','W']) then
- begin
- LinuxError:=ESysEnoent;
- exit;
- end;
- AssignPipe(pipi,pipo);
- if Linuxerror<>0 then
- exit;
- pid:=fpfork;
- if linuxerror<>0 then
- begin
- close(pipi);
- close(pipo);
- exit;
- end;
- if pid=0 then
- begin
- { We're in the child }
- if rw='W' then
- begin
- close(pipo);
- fpdup2(pipi,input);
- close(pipi);
- if linuxerror<>0 then
- halt(127);
- end
- else
- begin
- close(pipi);
- fpdup2(pipo,output);
- close(pipo);
- if linuxerror<>0 then
- halt(127);
- end;
- pp:=createshellargv(prog);
- fpExecve(pp^,pp,envp);
- halt(127);
- end
- else
- begin
- { We're in the parent }
- if rw='W' then
- begin
- close(pipi);
- f:=pipo;
- textrec(f).bufptr:=@textrec(f).buffer;
- end
- else
- begin
- close(pipo);
- f:=pipi;
- textrec(f).bufptr:=@textrec(f).buffer;
- end;
- {Save the process ID - needed when closing }
- pl:=@(textrec(f).userdata[2]);
- pl^:=pid;
- textrec(f).closefunc:=@PCloseText;
- end;
- end;
- Procedure POpen(var F:file;const Prog:String;rw:char);
- {
- Starts the program in 'Prog' and makes it's input or out put the
- other end of a pipe. If rw is 'w' or 'W', then whatever is written to
- F, will be read from stdin by the program in 'Prog'. The inverse is true
- for 'r' or 'R' : whatever the program in 'Prog' writes to stdout, can be
- read from 'f'.
- }
- var
- pipi,
- pipo : file;
- pid : longint;
- pl : ^longint;
- p,pp : ppchar;
- temp : string[255];
- begin
- LinuxError:=0;
- rw:=upcase(rw);
- if not (rw in ['R','W']) then
- begin
- LinuxError:=ESysEnoent;
- exit;
- end;
- AssignPipe(pipi,pipo);
- if Linuxerror<>0 then
- exit;
- pid:=fpfork;
- if linuxerror<>0 then
- begin
- close(pipi);
- close(pipo);
- exit;
- end;
- if pid=0 then
- begin
- { We're in the child }
- if rw='W' then
- begin
- close(pipo);
- fpdup2(filerec(pipi).handle,stdinputhandle);
- close(pipi);
- if linuxerror<>0 then
- halt(127);
- end
- else
- begin
- close(pipi);
- fpdup2(filerec(pipo).handle,stdoutputhandle);
- close(pipo);
- if linuxerror<>0 then
- halt(127);
- end;
- getmem(pp,sizeof(pchar)*4);
- temp:='/bin/sh'#0'-c'#0+prog+#0;
- p:=pp;
- p^:=@temp[1];
- inc(p);
- p^:=@temp[9];
- inc(p);
- p^:=@temp[12];
- inc(p);
- p^:=Nil;
- fpExecve(ansistring('/bin/sh'),pp,envp);
- halt(127);
- end
- else
- begin
- { We're in the parent }
- if rw='W' then
- begin
- close(pipi);
- f:=pipo;
- end
- else
- begin
- close(pipo);
- f:=pipi;
- end;
- {Save the process ID - needed when closing }
- pl:=@(filerec(f).userdata[2]);
- pl^:=pid;
- end;
- end;
- Function AssignStream(Var StreamIn,Streamout:text;Const Prog:String) : longint;
- {
- Starts the program in 'Prog' and makes its input and output the
- other end of two pipes, which are the stdin and stdout of a program
- specified in 'Prog'.
- streamout can be used to write to the program, streamin can be used to read
- the output of the program. See the following diagram :
- Parent Child
- STreamout --> Input
- Streamin <-- Output
- Return value is the process ID of the process being spawned, or -1 in case of failure.
- }
- var
- pipi,
- pipo : text;
- pid : longint;
- pl : ^Longint;
- begin
- LinuxError:=0;
- AssignStream:=-1;
- AssignPipe(streamin,pipo);
- if Linuxerror<>0 then
- exit;
- AssignPipe(pipi,streamout);
- if Linuxerror<>0 then
- exit;
- pid:=fpfork;
- if linuxerror<>0 then
- begin
- close(pipi);
- close(pipo);
- close (streamin);
- close (streamout);
- exit;
- end;
- if pid=0 then
- begin
- { We're in the child }
- { Close what we don't need }
- close(streamout);
- close(streamin);
- fpdup2(pipi,input);
- if linuxerror<>0 then
- halt(127);
- close(pipi);
- fpdup2(pipo,output);
- if linuxerror<>0 then
- halt (127);
- close(pipo);
- Execl(Prog);
- halt(127);
- end
- else
- begin
- { we're in the parent}
- close(pipo);
- close(pipi);
- {Save the process ID - needed when closing }
- pl:=@(textrec(StreamIn).userdata[2]);
- pl^:=pid;
- textrec(StreamIn).closefunc:=@PCloseText;
- {Save the process ID - needed when closing }
- pl:=@(textrec(StreamOut).userdata[2]);
- pl^:=pid;
- textrec(StreamOut).closefunc:=@PCloseText;
- AssignStream:=Pid;
- end;
- end;
- function AssignStream(var StreamIn, StreamOut, StreamErr: Text; const prog: String): LongInt;
- {
- Starts the program in 'prog' and makes its input, output and error output the
- other end of three pipes, which are the stdin, stdout and stderr of a program
- specified in 'prog'.
- StreamOut can be used to write to the program, StreamIn can be used to read
- the output of the program, StreamErr reads the error output of the program.
- See the following diagram :
- Parent Child
- StreamOut --> StdIn (input)
- StreamIn <-- StdOut (output)
- StreamErr <-- StdErr (error output)
- }
- var
- PipeIn, PipeOut, PipeErr: text;
- pid: LongInt;
- pl: ^LongInt;
- begin
- LinuxError := 0;
- AssignStream := -1;
- // Assign pipes
- AssignPipe(StreamIn, PipeOut);
- if LinuxError <> 0 then exit;
- AssignPipe(StreamErr, PipeErr);
- if LinuxError <> 0 then begin
- Close(StreamIn);
- Close(PipeOut);
- exit;
- end;
- AssignPipe(PipeIn, StreamOut);
- if LinuxError <> 0 then begin
- Close(StreamIn);
- Close(PipeOut);
- Close(StreamErr);
- Close(PipeErr);
- exit;
- end;
- // Fork
- pid := fpFork;
- if LinuxError <> 0 then begin
- Close(StreamIn);
- Close(PipeOut);
- Close(StreamErr);
- Close(PipeErr);
- Close(PipeIn);
- Close(StreamOut);
- exit;
- end;
- if pid = 0 then begin
- // *** We are in the child ***
- // Close what we don not need
- Close(StreamOut);
- Close(StreamIn);
- Close(StreamErr);
- // Connect pipes
- fpdup2(PipeIn, Input);
- if LinuxError <> 0 then Halt(127);
- Close(PipeIn);
- fpdup2(PipeOut, Output);
- if LinuxError <> 0 then Halt(127);
- Close(PipeOut);
- fpdup2(PipeErr, StdErr);
- if LinuxError <> 0 then Halt(127);
- Close(PipeErr);
- // Execute program
- Execl(Prog);
- Halt(127);
- end else begin
- // *** We are in the parent ***
- Close(PipeErr);
- Close(PipeOut);
- Close(PipeIn);
- // Save the process ID - needed when closing
- pl := @(TextRec(StreamIn).userdata[2]);
- pl^ := pid;
- TextRec(StreamIn).closefunc := @PCloseText;
- // Save the process ID - needed when closing
- pl := @(TextRec(StreamOut).userdata[2]);
- pl^ := pid;
- TextRec(StreamOut).closefunc := @PCloseText;
- // Save the process ID - needed when closing
- pl := @(TextRec(StreamErr).userdata[2]);
- pl^ := pid;
- TextRec(StreamErr).closefunc := @PCloseText;
- AssignStream := pid;
- end;
- end;
- {******************************************************************************
- General information calls
- ******************************************************************************}
- {$ifndef BSD}
- Function GetDomainName:String; { linux only!}
- // domainname is a glibc extension.
-
- {
- Get machines domain name. Returns empty string if not set.
- }
- Var
- Sysn : utsname;
- begin
- fpUname(Sysn);
- linuxerror:=fpgeterrno;;
- If linuxerror<>0 then
- getdomainname:=''
- else
- getdomainname:=strpas(@Sysn.domain[0]);
- end;
- {$endif}
- Function GetHostName:String;
- {
- Get machines name. Returns empty string if not set.
- }
- Var
- Sysn : utsname;
- begin
- fpuname(Sysn);
- linuxerror:=fpgeterrno;;
- If linuxerror<>0 then
- gethostname:=''
- else
- gethostname:=strpas(@Sysn.nodename[0]);
- end;
- {******************************************************************************
- Signal handling calls
- ******************************************************************************}
- procedure SigRaise(sig:integer);
- begin
- fpKill(fpGetPid,Sig);
- end;
- {******************************************************************************
- IOCtl and Termios calls
- ******************************************************************************}
- Function TCGetAttr(fd:longint;var tios:TermIOS):boolean;
- begin
- {$ifndef BSD}
- TCGetAttr:=fpIOCtl(fd,TCGETS,@tios)>0;
- {$else}
- TCGETAttr:=fpIoCtl(Fd,TIOCGETA,@tios)>0;
- {$endif}
- end;
- Function TCSetAttr(fd:longint;OptAct:longint;const tios:TermIOS):boolean;
- var
- nr:longint;
- begin
- {$ifndef BSD}
- case OptAct of
- TCSANOW : nr:=TCSETS;
- TCSADRAIN : nr:=TCSETSW;
- TCSAFLUSH : nr:=TCSETSF;
- {$else}
- case OptAct of
- TCSANOW : nr:=TIOCSETA;
- TCSADRAIN : nr:=TIOCSETAW;
- TCSAFLUSH : nr:=TIOCSETAF;
- {$endif}
- else
- begin
- fpsetErrNo(ESysEINVAL);
- TCSetAttr:=false;
- exit;
- end;
- end;
- TCSetAttr:=fpIOCtl(fd,nr,@Tios)>0;
- end;
- Procedure CFSetISpeed(var tios:TermIOS;speed:Cardinal);
- begin
- {$ifndef BSD}
- tios.c_cflag:=(tios.c_cflag and (not CBAUD)) or speed;
- {$else}
- tios.c_ispeed:=speed; {Probably the Bxxxx speed constants}
- {$endif}
- end;
- Procedure CFSetOSpeed(var tios:TermIOS;speed:Cardinal);
- begin
- {$ifndef BSD}
- CFSetISpeed(tios,speed);
- {$else}
- tios.c_ospeed:=speed;
- {$endif}
- end;
- Procedure CFMakeRaw(var tios:TermIOS);
- begin
- {$ifndef BSD}
- with tios do
- begin
- c_iflag:=c_iflag and (not (IGNBRK or BRKINT or PARMRK or ISTRIP or
- INLCR or IGNCR or ICRNL or IXON));
- c_oflag:=c_oflag and (not OPOST);
- c_lflag:=c_lflag and (not (ECHO or ECHONL or ICANON or ISIG or IEXTEN));
- c_cflag:=(c_cflag and (not (CSIZE or PARENB))) or CS8;
- end;
- {$else}
- with tios do
- begin
- c_iflag:=c_iflag and (not (IMAXBEL or IXOFF or INPCK or BRKINT or
- PARMRK or ISTRIP or INLCR or IGNCR or ICRNL or IXON or
- IGNPAR));
- c_iflag:=c_iflag OR IGNBRK;
- c_oflag:=c_oflag and (not OPOST);
- c_lflag:=c_lflag and (not (ECHO or ECHOE or ECHOK or ECHONL or ICANON or
- ISIG or IEXTEN or NOFLSH or TOSTOP or PENDIN));
- c_cflag:=(c_cflag and (not (CSIZE or PARENB))) or (CS8 OR cread);
- c_cc[VMIN]:=1;
- c_cc[VTIME]:=0;
- end;
- {$endif}
- end;
- Function TCSendBreak(fd,duration:longint):boolean;
- begin
- {$ifndef BSD}
- TCSendBreak:=fpIOCtl(fd,TCSBRK,pointer(duration))>0;
- {$else}
- TCSendBreak:=fpIOCtl(fd,TIOCSBRK,0)>0;
- {$endif}
- end;
- Function TCSetPGrp(fd,id:longint):boolean;
- begin
- TCSetPGrp:=fpIOCtl(fd,TIOCSPGRP,pointer(id))>0;
- end;
- Function TCGetPGrp(fd:longint;var id:longint):boolean;
- begin
- TCGetPGrp:=fpIOCtl(fd,TIOCGPGRP,@id)>0;
- end;
- Function TCDrain(fd:longint):boolean;
- begin
- {$ifndef BSD}
- TCDrain:=fpIOCtl(fd,TCSBRK,pointer(1))>0;
- {$else}
- TCDrain:=fpIOCtl(fd,TIOCDRAIN,0)>0; {Should set timeout to 1 first?}
- {$endif}
- end;
- Function TCFlow(fd,act:longint):boolean;
- begin
- {$ifndef BSD}
- TCFlow:=fpIOCtl(fd,TCXONC,pointer(act))>0;
- {$else}
- case act OF
- TCOOFF : TCFlow:=fpIoctl(fd,TIOCSTOP,0)>0;
- TCOOn : TCFlow:=fpIOctl(Fd,TIOCStart,0)>0;
- TCIOFF : {N/I}
- end;
- {$endif}
- end;
- Function TCFlush(fd,qsel:longint):boolean;
- begin
- {$ifndef BSD}
- TCFlush:=fpIOCtl(fd,TCFLSH,pointer(qsel))>0;
- {$else}
- TCFlush:=fpIOCtl(fd,TIOCFLUSH,pointer(qsel))>0;
- {$endif}
- end;
- Function IsATTY(Handle:Longint):Boolean;
- {
- Check if the filehandle described by 'handle' is a TTY (Terminal)
- }
- var
- t : Termios;
- begin
- IsAtty:=TCGetAttr(Handle,t);
- end;
- Function IsATTY(f: text):Boolean;
- {
- Idem as previous, only now for text variables.
- }
- begin
- IsATTY:=IsaTTY(textrec(f).handle);
- end;
- function TTYName(Handle:Longint):string;
- {
- Return the name of the current tty described by handle f.
- returns empty string in case of an error.
- }
- var
- mydev,
- myino : longint;
- st : stat;
- function mysearch(n:string): boolean;
- {searches recursively for the device in the directory given by n,
- returns true if found and sets the name of the device in ttyname}
- var dirstream : pdir;
- d : pdirent;
- name : string;
- st : stat;
- begin
- dirstream:=fpopendir(n);
- if (linuxerror<>0) then
- exit;
- d:=fpReaddir(dirstream^);
- while (d<>nil) do
- begin
- name:=n+'/'+strpas(@(d^.d_name));
- fpstat(name,st);
- if linuxerror=0 then
- begin
- if (fpISDIR(st.st_mode)) and { if it is a directory }
- (strpas(@(d^.d_name))<>'.') and { but not ., .. and fd subdirs }
- (strpas(@(d^.d_name))<>'..') and
- (strpas(@(d^.d_name))<>'') and
- (strpas(@(d^.d_name))<>'fd') then
- begin {we found a directory, search inside it}
- if mysearch(name) then
- begin {the device is here}
- fpclosedir(dirstream^); {then don't continue searching}
- mysearch:=true;
- exit;
- end;
- end
- else if (d^.d_fileno=myino) and (st.st_dev=mydev) then
- begin
- fpclosedir(dirstream^);
- ttyname:=name;
- mysearch:=true;
- exit;
- end;
- end;
- d:=fpReaddir(dirstream^);
- end;
- fpclosedir(dirstream^);
- mysearch:=false;
- end;
- begin
- TTYName:='';
- fpfstat(handle,st);
- if (fpgeterrno<>0) and isatty (handle) then
- exit;
- mydev:=st.st_dev;
- myino:=st.st_ino;
- mysearch('/dev');
- end;
- function TTYName(var F:Text):string;
- {
- Idem as previous, only now for text variables;
- }
- begin
- TTYName:=TTYName(textrec(f).handle);
- end;
- {******************************************************************************
- Utility calls
- ******************************************************************************}
- Function Octal(l:longint):longint;
- {
- Convert an octal specified number to decimal;
- }
- var
- octnr,
- oct : longint;
- begin
- octnr:=0;
- oct:=0;
- while (l>0) do
- begin
- oct:=oct or ((l mod 10) shl octnr);
- l:=l div 10;
- inc(octnr,3);
- end;
- Octal:=oct;
- end;
- {$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
- {$DEFINE FPC_FEXPAND_GETENVPCHAR} { GetEnv result is a PChar }
- {$I fexpand.inc}
- {$UNDEF FPC_FEXPAND_GETENVPCHAR}
- {$UNDEF FPC_FEXPAND_TILDE}
- Function FSearch(const path:pathstr;dirlist:string):pathstr;
- {
- Searches for a file 'path' in the list of direcories in 'dirlist'.
- returns an empty string if not found. Wildcards are NOT allowed.
- If dirlist is empty, it is set to '.'
- }
- Var
- NewDir : PathStr;
- p1 : Longint;
- Info : Stat;
- Begin
- {Replace ':' with ';'}
- for p1:=1to length(dirlist) do
- if dirlist[p1]=':' then
- dirlist[p1]:=';';
- {Check for WildCards}
- If (Pos('?',Path) <> 0) or (Pos('*',Path) <> 0) Then
- FSearch:='' {No wildcards allowed in these things.}
- Else
- Begin
- Dirlist:='.;'+dirlist;{Make sure current dir is first to be searched.}
- Repeat
- p1:=Pos(';',DirList);
- If p1=0 Then
- p1:=255;
- NewDir:=Copy(DirList,1,P1 - 1);
- if NewDir[Length(NewDir)]<>'/' then
- NewDir:=NewDir+'/';
- NewDir:=NewDir+Path;
- Delete(DirList,1,p1);
- if FpStat(NewDir,Info)>=0 then
- Begin
- If Pos('./',NewDir)=1 Then
- Delete(NewDir,1,2);
- {DOS strips off an initial .\}
- End
- Else
- NewDir:='';
- Until (DirList='') or (Length(NewDir) > 0);
- FSearch:=NewDir;
- End;
- End;
- Procedure Globfree(var p : pglob);
- {
- Release memory occupied by pglob structure, and names in it.
- sets p to nil.
- }
- var
- temp : pglob;
- begin
- while assigned(p) do
- begin
- temp:=p^.next;
- if assigned(p^.name) then
- freemem(p^.name);
- dispose(p);
- p:=temp;
- end;
- end;
- Function Glob(Const path:pathstr):pglob;
- {
- Fills a tglob structure with entries matching path,
- and returns a pointer to it. Returns nil on error,
- linuxerror is set accordingly.
- }
- var
- temp,
- temp2 : string[255];
- thedir : pdir;
- buffer : pdirent;
- root,
- current : pglob;
- begin
- { Get directory }
- temp:=dirname(path);
- if temp='' then
- temp:='.';
- temp:=temp+#0;
- thedir:=fpopendir(@temp[1]);
- if thedir=nil then
- begin
- glob:=nil;
- linuxerror:=fpgeterrno;;
- exit;
- end;
- temp:=basename(path,''); { get the pattern }
- if thedir^.dd_fd<0 then
- begin
- linuxerror:=fpgeterrno;;
- glob:=nil;
- exit;
- end;
- {get the entries}
- root:=nil;
- current:=nil;
- repeat
- buffer:=fpreaddir(thedir^);
- if buffer=nil then
- break;
- temp2:=strpas(@(buffer^.d_name[0]));
- if fnmatch(temp,temp2) then
- begin
- if root=nil then
- begin
- new(root);
- current:=root;
- end
- else
- begin
- new(current^.next);
- current:=current^.next;
- end;
- if current=nil then
- begin
- linuxerror:=ESysENOMEM;
- globfree(root);
- break;
- end;
- current^.next:=nil;
- getmem(current^.name,length(temp2)+1);
- if current^.name=nil then
- begin
- linuxerror:=ESysENOMEM;
- globfree(root);
- break;
- end;
- move(buffer^.d_name[0],current^.name^,length(temp2)+1);
- end;
- until false;
- fpclosedir(thedir^);
- glob:=root;
- end;
- Function GetFS (var T:Text):longint;
- {
- Get File Descriptor of a text file.
- }
- begin
- if textrec(t).mode=fmclosed then
- exit(-1)
- else
- GETFS:=textrec(t).Handle
- end;
- Function GetFS(Var F:File):longint;
- {
- Get File Descriptor of an unTyped file.
- }
- begin
- { Handle and mode are on the same place in textrec and filerec. }
- if filerec(f).mode=fmclosed then
- exit(-1)
- else
- GETFS:=filerec(f).Handle
- end;
- {--------------------------------
- Stat.Mode Macro's
- --------------------------------}
- Initialization
- InitLocalTime;
- finalization
- DoneLocalTime;
- End.
- {
- $Log$
- Revision 1.37 2003-09-17 19:07:44 marco
- * more fixes for Unix<->unixutil
- Revision 1.36 2003/09/17 17:30:46 marco
- * Introduction of unixutil
- Revision 1.35 2003/09/16 21:46:27 marco
- * small fixes, checking things on linux
- Revision 1.34 2003/09/16 20:52:24 marco
- * small cleanups. Mostly killing of already commented code in unix etc
- Revision 1.33 2003/09/16 16:13:56 marco
- * fdset functions renamed to fp<posix name>
- Revision 1.32 2003/09/15 20:08:49 marco
- * small fixes. FreeBSD now cycles
- Revision 1.31 2003/09/14 20:15:01 marco
- * Unix reform stage two. Remove all calls from Unix that exist in Baseunix.
- Revision 1.30 2003/07/08 21:23:24 peter
- * sparc fixes
- Revision 1.29 2003/05/30 19:58:40 marco
- * Getting NetBSD/i386 to compile.
- Revision 1.28 2003/05/29 19:16:16 marco
- * fixed a small *BSD gotcha
- Revision 1.27 2003/05/24 20:39:54 jonas
- * fixed ExitCode translation in WaitProcess for Linux and Darwin (and
- probably other BSD's as well)
- Revision 1.26 2003/03/11 08:27:59 michael
- * stringtoppchar should use tabs instead of backspace as delimiter
- Revision 1.25 2002/12/18 16:50:39 marco
- * Unix RTL generic parts. Linux working, *BSD will follow shortly
- Revision 1.24 2002/09/07 16:01:28 peter
- * old logs removed and tabs fixed
- Revision 1.23 2002/08/06 13:30:46 sg
- * replaced some Longints with Cardinals, to mach the C headers
- * updated the termios record
- Revision 1.22 2002/03/05 20:04:25 michael
- + Patch from Sebastian for FCNTL call
- Revision 1.21 2002/01/02 12:22:54 marco
- * Removed ifdef arround getepoch.
- }
|