paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-31 14:31:38 +01:00
Code Issues Packages Projects Releases Wiki Activity
b5203c5b09
fpc/rtl/linux/linux.pp

3537 lines
74 KiB
ObjectPascal
Raw Blame History

{
This file is part of the Free Pascal run time library.
Copyright (c) 1993,97 by Michael Van Canneyt,
member 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 Linux;
Interface
{ Get Types and Constants }
{$i sysconst.inc}
{$i systypes.inc}
{ Get System call numbers and error-numbers}
{$i sysnr.inc}
{$i errno.inc}
var
ErrNo,
LinuxError : Longint;
{********************
Process
********************}
Const
{ For getting/setting priority }
Prio_Process = 0;
Prio_PGrp = 1;
Prio_User = 2;
{********************
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;
ComStr = String[255];
PathStr = String[255];
DirStr = String[255];
NameStr = String[255];
ExtStr = String[255];
const
{ For testing access rights }
R_OK = 4;
W_OK = 2;
X_OK = 1;
F_OK = 0;
{ For File control mechanism }
F_GetFd = 1;
F_SetFd = 2;
F_GetFl = 3;
F_SetFl = 4;
F_GetLk = 5;
F_SetLk = 6;
F_SetLkW = 7;
F_GetOwn = 8;
F_SetOwn = 9;
{********************
Signal
********************}
Const
{ For sending a signal }
SA_NOCLDSTOP = 1;
SA_SHIRQ = $04000000;
SA_STACK = $08000000;
SA_RESTART = $10000000;
SA_INTERRUPT = $20000000;
SA_NOMASK = $40000000;
SA_ONESHOT = $80000000;
SIG_BLOCK = 0;
SIG_UNBLOCK = 1;
SIG_SETMASK = 2;
SIG_DFL = 0 ;
SIG_IGN = 1 ;
SIG_ERR = -1 ;
SIGHUP = 1;
SIGINT = 2;
SIGQUIT = 3;
SIGILL = 4;
SIGTRAP = 5;
SIGABRT = 6;
SIGIOT = 6;
SIGBUS = 7;
SIGFPE = 8;
SIGKILL = 9;
SIGUSR1 = 10;
SIGSEGV = 11;
SIGUSR2 = 12;
SIGPIPE = 13;
SIGALRM = 14;
SIGTerm = 15;
SIGSTKFLT = 16;
SIGCHLD = 17;
SIGCONT = 18;
SIGSTOP = 19;
SIGTSTP = 20;
SIGTTIN = 21;
SIGTTOU = 22;
SIGURG = 23;
SIGXCPU = 24;
SIGXFSZ = 25;
SIGVTALRM = 26;
SIGPROF = 27;
SIGWINCH = 28;
SIGIO = 29;
SIGPOLL = SIGIO;
SIGPWR = 30;
SIGUNUSED = 31;
Type
SignalHandler = Procedure(Sig : Integer);
PSignalHandler = ^SignalHandler;
SignalRestorer = Procedure;
PSignalRestorer = ^SignalRestorer;
SigSet = Integer;
PSigSet = ^SigSet;
{$PACKRECORDS 1}
SigActionRec = record
Sa_Handler : ^SignalHandler;
Sa_Mask : longint;
Sa_Flags : Integer;
Sa_restorer : ^SignalRestorer;{ Obsolete - Don't use }
end;
PSigActionRec = ^SigActionRec;
{$PACKRECORDS NORMAL}
{********************
IOCtl(TermIOS)
********************}
Const
{ Amount of Control Chars }
NCCS = 19;
NCC = 8;
{ For Terminal handling }
TCGETS = $5401;
TCSETS = $5402;
TCSETSW = $5403;
TCSETSF = $5404;
TCGETA = $5405;
TCSETA = $5406;
TCSETAW = $5407;
TCSETAF = $5408;
TCSBRK = $5409;
TCXONC = $540A;
TCFLSH = $540B;
TIOCEXCL = $540C;
TIOCNXCL = $540D;
TIOCSCTTY = $540E;
TIOCGPGRP = $540F;
TIOCSPGRP = $5410;
TIOCOUTQ = $5411;
TIOCSTI = $5412;
TIOCGWINSZ = $5413;
TIOCSWINSZ = $5414;
TIOCMGET = $5415;
TIOCMBIS = $5416;
TIOCMBIC = $5417;
TIOCMSET = $5418;
TIOCGSOFTCAR = $5419;
TIOCSSOFTCAR = $541A;
FIONREAD = $541B;
TIOCINQ = FIONREAD;
TIOCLINUX = $541C;
TIOCCONS = $541D;
TIOCGSERIAL = $541E;
TIOCSSERIAL = $541F;
TIOCPKT = $5420;
FIONBIO = $5421;
TIOCNOTTY = $5422;
TIOCSETD = $5423;
TIOCGETD = $5424;
TCSBRKP = $5425;
TIOCTTYGSTRUCT = $5426;
FIONCLEX = $5450;
FIOCLEX = $5451;
FIOASYNC = $5452;
TIOCSERCONFIG = $5453;
TIOCSERGWILD = $5454;
TIOCSERSWILD = $5455;
TIOCGLCKTRMIOS = $5456;
TIOCSLCKTRMIOS = $5457;
TIOCSERGSTRUCT = $5458;
TIOCSERGETLSR = $5459;
TIOCSERGETMULTI = $545A;
TIOCSERSETMULTI = $545B;
TIOCMIWAIT = $545C;
TIOCGICOUNT = $545D;
TIOCPKT_DATA = 0;
TIOCPKT_FLUSHREAD = 1;
TIOCPKT_FLUSHWRITE = 2;
TIOCPKT_STOP = 4;
TIOCPKT_START = 8;
TIOCPKT_NOSTOP = 16;
TIOCPKT_DOSTOP = 32;
Type
{$PACKRECORDS 1}
winsize = record
ws_row,
ws_col,
ws_xpixel,
ws_ypixel : byte;
end;
TermIO = record
c_iflag, { input mode flags }
c_oflag, { output mode flags }
c_cflag, { control mode flags }
c_lflag : Word; { local mode flags }
c_line : Word; { line discipline - careful, only High byte in use}
c_cc : array [0..NCC-1] of char;{ control characters }
end;
TermIOS = record
c_iflag,
c_oflag,
c_cflag,
c_lflag : longint;
c_line : char;
c_cc : array[0..NCCS-1] of byte;
end;
{$PACKRECORDS 2}
const
InitCC:array[0..NCCS-1] of byte=(3,34,177,25,4,0,1,0,21,23,32,0,22,17,27,26,0,0,0);
const
{c_cc characters}
VINTR = 0;
VQUIT = 1;
VERASE = 2;
VKILL = 3;
VEOF = 4;
VTIME = 5;
VMIN = 6;
VSWTC = 7;
VSTART = 8;
VSTOP = 9;
VSUSP = 10;
VEOL = 11;
VREPRINT = 12;
VDISCARD = 13;
VWERASE = 14;
VLNEXT = 15;
VEOL2 = 16;
{c_iflag bits}
IGNBRK = $0000001;
BRKINT = $0000002;
IGNPAR = $0000004;
PARMRK = $0000008;
INPCK = $0000010;
ISTRIP = $0000020;
INLCR = $0000040;
IGNCR = $0000080;
ICRNL = $0000100;
IUCLC = $0000200;
IXON = $0000400;
IXANY = $0000800;
IXOFF = $0001000;
IMAXBEL = $0002000;
{c_oflag bits}
OPOST = $0000001;
OLCUC = $0000002;
ONLCR = $0000004;
OCRNL = $0000008;
ONOCR = $0000010;
ONLRET = $0000020;
OFILL = $0000040;
OFDEL = $0000080;
NLDLY = $0000100;
NL0 = $0000000;
NL1 = $0000100;
CRDLY = $0000600;
CR0 = $0000000;
CR1 = $0000200;
CR2 = $0000400;
CR3 = $0000600;
TABDLY = $0001800;
TAB0 = $0000000;
TAB1 = $0000800;
TAB2 = $0001000;
TAB3 = $0001800;
XTABS = $0001800;
BSDLY = $0002000;
BS0 = $0000000;
BS1 = $0002000;
VTDLY = $0004000;
VT0 = $0000000;
VT1 = $0004000;
FFDLY = $0008000;
FF0 = $0000000;
FF1 = $0008000;
{c_cflag bits}
CBAUD = $000100F;
B0 = $0000000;
B50 = $0000001;
B75 = $0000002;
B110 = $0000003;
B134 = $0000004;
B150 = $0000005;
B200 = $0000006;
B300 = $0000007;
B600 = $0000008;
B1200 = $0000009;
B1800 = $000000A;
B2400 = $000000B;
B4800 = $000000C;
B9600 = $000000D;
B19200 = $000000E;
B38400 = $000000F;
EXTA = B19200;
EXTB = B38400;
CSIZE = $0000030;
CS5 = $0000000;
CS6 = $0000010;
CS7 = $0000020;
CS8 = $0000030;
CSTOPB = $0000040;
CREAD = $0000080;
PARENB = $0000100;
PARODD = $0000200;
HUPCL = $0000400;
CLOCAL = $0000800;
CBAUDEX = $0001000;
B57600 = $0001001;
B115200 = $0001002;
B230400 = $0001003;
B460800 = $0001004;
CIBAUD = $100F0000;
CMSPAR = $40000000;
CRTSCTS = $80000000;
{c_lflag bits}
ISIG = $0000001;
ICANON = $0000002;
XCASE = $0000004;
ECHO = $0000008;
ECHOE = $0000010;
ECHOK = $0000020;
ECHONL = $0000040;
NOFLSH = $0000080;
TOSTOP = $0000100;
ECHOCTL = $0000200;
ECHOPRT = $0000400;
ECHOKE = $0000800;
FLUSHO = $0001000;
PENDIN = $0004000;
IEXTEN = $0008000;
{c_line bits}
TIOCM_LE = $001;
TIOCM_DTR = $002;
TIOCM_RTS = $004;
TIOCM_ST = $008;
TIOCM_SR = $010;
TIOCM_CTS = $020;
TIOCM_CAR = $040;
TIOCM_RNG = $080;
TIOCM_DSR = $100;
TIOCM_CD = TIOCM_CAR;
TIOCM_RI = TIOCM_RNG;
TIOCM_OUT1 = $2000;
TIOCM_OUT2 = $4000;
{TCSetAttr}
TCSANOW = 0;
TCSADRAIN = 1;
TCSAFLUSH = 2;
{TCFlow}
TCOOFF = 0;
TCOON = 1;
TCIOFF = 2;
TCION = 3;
{TCFlush}
TCIFLUSH = 0;
TCOFLUSH = 1;
TCIOFLUSH = 2;
{********************
Info
********************}
Type
{$PACKRECORDS 1}
utimbuf = record
actime,modtime : Longint;
end;
TSysinfo = record
uptime : longint;
loads : array[1..3] of longint;
totalram,
freeram,
sharedram,
bufferram,
totalswap,
freeswap : longint;
procs : integer;
s : string[18];
end;
{$PACKRECORDS 2}
{******************************************************************************
Procedure/Functions
******************************************************************************}
Function SysCall(callnr:longint;var regs:SysCallregs):longint;
{**************************
Time/Date Handling
***************************}
Function GetEpochTime:longint;
Procedure GetTimeOfDay(var tv:timeval;var tz:timezone);
Function GetTimeOfDay: longint;
Procedure EpochToLocal(epoch:longint;var year,month,day,hour,minute,second:Word);
Function LocalToEpoch(year,month,day,hour,minute,second:Word):Longint;
Procedure GetTime(Var Hour,Minute,Second:Word);
Procedure GetDate(Var Year,Month,Day:Word);
{ For compatibility with earlier versions }
Procedure EpochToLocal(epoch:longint;var year,month,day,hour,minute,second:Integer);
Function LocalToEpoch(year,month,day,hour,minute,second:Integer):Longint;
Procedure GetTime(Var Hour,Minute,Second:Integer);
Procedure GetDate(Var Year,Month,Day:Integer);
{**************************
Process Handling
***************************}
function CreateShellArgV(const prog:string):ppchar;
Procedure Execve(Path:pathstr;args:ppchar;ep:ppchar);
Procedure Execve(path:pchar;args:ppchar;ep:ppchar);
Procedure Execv(const path:pathstr;args:ppchar);
Procedure Execvp(Path:Pathstr;Args:ppchar;Ep:ppchar);
Procedure Execl(const Todo:string);
Procedure Execle(Todo:string;Ep:ppchar);
Procedure Execlp(Todo:string;Ep:ppchar);
Function Shell(const Command:String):Longint;
Function Fork:longint;
Function WaitPid(Pid:longint;Status:pointer;Options:Integer):Longint;
Procedure Nice(N:integer);
Function GetPriority(Which,Who:Integer):integer;
Procedure SetPriority(Which:Integer;Who:Integer;What:Integer);
Function GetPid:LongInt;
Function GetPPid:LongInt;
Function GetUid:Longint;
Function GetEUid:Longint;
Function GetGid:Longint;
Function GetEGid:Longint;
{**************************
File Handling
***************************}
Function fdOpen(pathname:string;flags:longint):longint;
Function fdOpen(pathname:string;flags,mode:longint):longint;
Function fdOpen(pathname:pchar;flags:longint):longint;
Function fdOpen(pathname:pchar;flags,mode:longint):longint;
Function fdClose(fd:longint):boolean;
Function fdRead(fd:longint;var buf;size:longint):longint;
Function fdWrite(fd:longint;var buf;size:longint):longint;
Function fdTruncate(fd,size:longint):boolean;
Function fdSeek (fd,pos,seektype :longint): longint;
Function fdFlush (fd : Longint) : Boolean;
Function Link(OldPath,NewPath:pathstr):boolean;
Function SymLink(OldPath,NewPath:pathstr):boolean;
Function UnLink(Path:pathstr):boolean;
Function UnLink(Path:pchar):Boolean;
Function Chown(path:pathstr;NewUid,NewGid:longint):boolean;
Function Chmod(path:pathstr;Newmode:longint):boolean;
Function Utime(path:pathstr;utim:utimbuf):boolean;
Function Access(Path:Pathstr ;mode:integer):boolean;
Function Umask(Mask:Integer):integer;
Function Flock (fd,mode : longint) : boolean;
Function Flock (var T : text;mode : longint) : boolean;
Function Flock (var F : File;mode : longint) : boolean;
Function FStat(Path:Pathstr;Var Info:stat):Boolean;
Function FStat(Fd:longint;Var Info:stat):Boolean;
Function FStat(var F:Text;Var Info:stat):Boolean;
Function FStat(var F:File;Var Info:stat):Boolean;
Function Lstat(Filename: PathStr;var Info:stat):Boolean;
Function FSStat(Path:Pathstr;Var Info:statfs):Boolean;
Function FSStat(Fd: Longint;Var Info:statfs):Boolean;
Function Fcntl(Fd:Text;Cmd:Integer):integer;
Procedure Fcntl(Fd:Text;Cmd:Integer;Arg:Longint);
Function Dup(oldfile,newfile:longint):Boolean;
Function Dup(var oldfile,newfile:text):Boolean;
Function Dup(var oldfile,newfile:file):Boolean;
Function Dup2(oldfile,newfile:longint):Boolean;
Function Dup2(var oldfile,newfile:text):Boolean;
Function Dup2(var oldfile,newfile:file):Boolean;
Function Select(N:longint;readfds,writefds,exceptfds:PFDSet;TimeOut:PTimeVal):longint;
Function Select(N:longint;readfds,writefds,exceptfds:PFDSet;TimeOut:Longint):longint;
Function SelectText(var T:Text;TimeOut :PTimeVal):Longint;
{**************************
Directory Handling
***************************}
Function OpenDir(f:pchar):pdir;
Function OpenDir(f: String):pdir;
function CloseDir(p:pdir):integer;
Function ReadDir(p:pdir):pdirent;
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 mkFifo(pathname:string;mode:longint):boolean;
Procedure AssignStream(Var StreamIn,Streamout:text;Const Prog:String);
{**************************
General information
***************************}
Function GetDomainName:String;
Function GetHostName:String;
Function GetEnv(P:string):Pchar;
Function Sysinfo(var Info:TSysinfo):Boolean;
Function Uname(var unamerec:utsname):Boolean;
{**************************
Signal
***************************}
Procedure SigAction(Signum:Integer;Var Act,OldAct:PSigActionRec );
Procedure SigProcMask (How:Integer;SSet,OldSSet:PSigSet);
Function SigPending:SigSet;
Procedure SigSuspend(Mask:Sigset);
Function Signal(Signum:Integer;Handler:PSignalHandler):PSignalHandler;
Function Kill(Pid:longint;Sig:integer):integer;
{**************************
IOCtl/Termios Functions
***************************}
Function IOCtl(Handle,Ndx: Longint;Data: Pointer):boolean;
Function TCGetAttr(fd:longint;var tios:TermIOS):boolean;
Function TCSetAttr(fd:longint;OptAct:longint;var tios:TermIOS):boolean;
Procedure CFSetISpeed(var tios:TermIOS;speed:Longint);
Procedure CFSetOSpeed(var tios:TermIOS;speed:Longint);
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;
{**************************
Port IO functions
***************************}
Function IOperm (From,Num : Cardinal; Value : Longint) : boolean;
Procedure WritePort (Port : Longint; Value : Byte);
Procedure WritePort (Port : Longint; Value : Word);
Procedure WritePort (Port : Longint; Value : Longint);
Procedure WritePortl (Port : Longint; Var Buf; Count: longint);
Procedure WritePortW (Port : Longint; Var Buf; Count: longint);
Procedure WritePortB (Port : Longint; Var Buf; Count: longint);
Procedure ReadPort (Port : Longint; Var Value : Byte);
Procedure ReadPort (Port : Longint; Var Value : Word);
Procedure ReadPort (Port : Longint; Var Value : Longint);
Procedure ReadPortL (Port : Longint; Var Buf; Count: longint);
Procedure ReadPortW (Port : Longint; Var Buf; Count: longint);
Procedure ReadPortB (Port : Longint; Var Buf; Count: longint);
{**************************
Utility functions
***************************}
Function Octal(l:longint):longint;
Function FExpand(Const Path: PathStr):PathStr;
Function FSearch(const path:pathstr;dirlist:string):pathstr;
Procedure FSplit(const Path:PathStr;Var Dir:DirStr;Var Name:NameStr;Var Ext:ExtStr);
Function Dirname(Const path:pathstr):pathstr;
Function Basename(Const path:pathstr;Const suf:pathstr):pathstr;
Function FNMatch(const Pattern,Name:string):Boolean;
Function Glob(Const path:pathstr):pglob;
Procedure Globfree(var p:pglob);
Function StringToPPChar(Var S:STring):ppchar;
Function GetFS(var T:Text):longint;
Function GetFS(Var F:File):longint;
{Filedescriptorsets}
Procedure FD_Zero(var fds:fdSet);
Procedure FD_Clr(fd:longint;var fds:fdSet);
Procedure FD_Set(fd:longint;var fds:fdSet);
Function FD_IsSet(fd:longint;var fds:fdSet):boolean;
{Stat.Mode Types}
Function S_ISLNK(m:integer):boolean;
Function S_ISREG(m:integer):boolean;
Function S_ISDIR(m:integer):boolean;
Function S_ISCHR(m:integer):boolean;
Function S_ISBLK(m:integer):boolean;
Function S_ISFIFO(m:integer):boolean;
Function S_ISSOCK(m:integer):boolean;
{******************************************************************************
Implementation
******************************************************************************}
Implementation
Uses Strings;
var
LocalTZ:TimeZone;
{ Get the definitions of textrec and filerec }
{$i textrec.inc}
{$i filerec.inc}
{ Raw System calls are in Syscalls.inc}
{$i syscalls.inc}
{******************************************************************************
Process related calls
******************************************************************************}
function CreateShellArgV(const prog:string):ppchar;
{
Create an argv which executes a command in a shell using /bin/sh -c
}
var
pp,p : ppchar;
temp : string;
begin
getmem(pp,4*4);
temp:='/bin/sh'#0'-c'#0+prog+#0;
pp^:=@temp[1];
p:=pp+4;
p^:=@temp[9];
p:=p+4;
p^:=@temp[12];
p:=p+4;
p^:=Nil;
CreateShellArgV:=pp;
end;
Function Fork:longint;
{
This function issues the 'fork' System call. the program is duplicated in memory
and Execution continues in parent and child process.
In the parent process, fork returns the PID of the child. In the child process,
zero is returned.
A negative value indicates that an error has occurred, the error is returned in
LinuxError.
}
var
regs:SysCallregs;
begin
Fork:=SysCall(SysCall_nr_fork,regs);
LinuxError:=Errno;
End;
Procedure Execve(path:pathstr;args:ppchar;ep:ppchar);
{
Replaces the current program by the program specified in path,
arguments in args are passed to Execve.
environment specified in ep is passed on.
}
var
regs:SysCallregs;
begin
path:=path+#0;
regs.reg2:=longint(@path[1]);
regs.reg3:=longint(args);
regs.reg4:=longint(ep);
SysCall(SysCall_nr_Execve,regs);
{ This only gets set when the call fails, otherwise we don't get here ! }
Linuxerror:=errno;
end;
Procedure Execve(path:pchar;args:ppchar;ep:ppchar);
{
Replaces the current program by the program specified in path,
arguments in args are passed to Execve.
environment specified in ep is passed on.
}
var
regs:SysCallregs;
begin
regs.reg2:=longint(path);
regs.reg3:=longint(args);
regs.reg4:=longint(ep);
SysCall(SysCall_nr_Execve,regs);
{ This only gets set when the call fails, otherwise we don't get here ! }
Linuxerror:=errno;
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
Execve(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(getenv('PATH'));
if thepath='' then
thepath:='.';
Path:=FSearch(path,thepath)
end
else
Path:='';
if Path='' then
linuxerror:=Sys_enoent
else
Execve(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;
ExecVE(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;
Function WaitPid(Pid:longint;Status:pointer;Options:Integer):Longint;
{
Waits until a child with PID Pid exits, or returns if it is exited already.
Any resources used by the child are freed.
The exit status is reported in the adress referred to by Status. It should
be a longint.
}
var
regs : SysCallregs;
begin
regs.reg2:=pid;
regs.reg3:=longint(status);
regs.reg4:=options;
WaitPid:=SysCall(SysCall_nr_waitpid,regs);
LinuxError:=errno;
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.
}
var
p : ppchar;
temp,pid : longint;
begin
pid:=fork;
if pid=-1 then
exit; {Linuxerror already set in Fork}
if pid=0 then
begin
{This is the child.}
p:=CreateShellArgv(command);
Execve(p^,p,envp);
exit(127);
end;
temp:=0;
WaitPid(pid,@temp,0);{Linuxerror is set there}
Shell:=temp;{ Return exit status }
end;
Function GetPriority(Which,Who:Integer):integer;
{
Get Priority of process, process group, or user.
Which : selects what kind of priority is used.
can be one of the following predefined Constants :
Prio_User.
Prio_PGrp.
Prio_Process.
Who : depending on which, this is , respectively :
Uid
Pid
Process Group id
Errors are reported in linuxerror _only_. (priority can be negative)
}
var
sr : Syscallregs;
begin
errno:=0;
if (which<prio_process) or (which>prio_user) then
begin
{ We can save an interrupt here }
getpriority:=0;
linuxerror:=Sys_einval;
end
else
begin
sr.reg2:=which;
sr.reg3:=who;
getpriority:=SysCall(Syscall_nr_getpriority,sr);
linuxerror:=errno;
end;
end;
Procedure SetPriority(Which:Integer;Who:Integer;What:Integer);
{
Set Priority of process, process group, or user.
Which : selects what kind of priority is used.
can be one of the following predefined Constants :
Prio_User.
Prio_PGrp.
Prio_Process.
Who : depending on value of which, this is, respectively :
Uid
Pid
Process Group id
what : A number between -20 and 20. -20 is most favorable, 20 least.
0 is the default.
}
var
sr : Syscallregs;
begin
errno:=0;
if ((which<prio_process) or (which>prio_user)) or ((what<-20) or (what>20)) then
linuxerror:=Sys_einval { We can save an interrupt here }
else
begin
sr.reg2:=which;
sr.reg3:=who;
sr.reg4:=what;
SysCall(Syscall_nr_setpriority,sr);
linuxerror:=errno;
end;
end;
Procedure Nice(N:integer);
{
Set process priority. A positive N means a lower priority.
A negative N decreases priority.
}
var
sr : Syscallregs;
begin
sr.reg2:=n;
SysCall(Syscall_nr_nice,sr);
linuxerror:=errno;
end;
Function GetPid:LongInt;
{
Get Process ID.
}
var
regs : SysCallregs;
begin
GetPid:=SysCall(SysCall_nr_getpid,regs);
linuxerror:=errno;
end;
Function GetPPid:LongInt;
{
Get Process ID of parent process.
}
var
regs : SysCallregs;
begin
GetPpid:=SysCall(SysCall_nr_getppid,regs);
linuxerror:=errno;
end;
Function GetUid:Longint;
{
Get User ID.
}
var
regs : SysCallregs;
begin
GetUid:=SysCall(SysCall_nr_getuid,regs);
Linuxerror:=errno;
end;
Function GetEUid:Longint;
{
Get _effective_ User ID.
}
var
regs : SysCallregs;
begin
GetEuid:=SysCall(SysCall_nr_geteuid,regs);
Linuxerror:=errno;
end;
Function GetGid:Longint;
{
Get Group ID.
}
var
regs : SysCallregs;
begin
Getgid:=SysCall(SysCall_nr_getgid,regs);
Linuxerror:=errno;
end;
Function GetEGid:Longint;
{
Get _effective_ Group ID.
}
var
regs : SysCallregs;
begin
GetEgid:=SysCall(SysCall_nr_getegid,regs);
Linuxerror:=errno;
end;
{******************************************************************************
Date and Time related calls
******************************************************************************}
Const
{Date Translation}
C1970=2440588;
D0 = 1461;
D1 = 146097;
D2 =1721119;
Function GregorianToJulian(Year,Month,Day:Longint):LongInt;
Var
Century,XYear: LongInt;
Begin
If Month<=2 Then
Begin
Dec(Year);
Inc(Month,12);
End;
Dec(Month,3);
Century:=(longint(Year Div 100)*D1) shr 2;
XYear:=(longint(Year Mod 100)*D0) shr 2;
GregorianToJulian:=((((Month*153)+2) div 5)+Day)+D2+XYear+Century;
End;
Procedure JulianToGregorian(JulianDN:LongInt;Var Year,Month,Day:Word);
Var
YYear,XYear,Temp : LongInt;
Begin
Temp:=((JulianDN-D2) shl 2)-1;
JulianDN:=Temp Div D1;
XYear:=(Temp Mod D1) or 3;
YYear:=(XYear Div D0);
Temp:=((((XYear mod D0)+4) shr 2)*5)-3;
Day:=((Temp Mod 153)+5) Div 5;
Month:=Temp Div 153;
If Month>=10 Then
Begin
inc(YYear);
dec(Month,12);
End;
inc(Month,3);
Year:=YYear+(JulianDN*100);
end;
Procedure GetTimeOfDay(var tv:timeval;var tz:timezone);
{
Get the time of day and timezone.
}
var
regs : SysCallregs;
begin
regs.reg2:=longint(@tv);
regs.reg3:=longint(@tz);
SysCall(SysCall_nr_gettimeofday,regs);
LinuxError:=Errno;
end;
Function GetTimeOfDay: longint;
{
Get the number of seconds since 00:00, January 1 1970, GMT
the time NOT corrected any way
}
var
t : timeval ;
tz : timezone ;
begin
gettimeofday(t,tz);{Sets LinuxError also}
GetTimeOfDay:=t.sec;
end;
Function GetEpochTime:longint;
{
Get the number of seconds since 00:00, January 1 1970, GMT
the time is corrected according to the time zone, but NOT
DST corrected.
}
var
t : timeval ;
tz : timezone ;
begin
gettimeofday(t,tz);{Sets LinuxError also}
Getepochtime:=t.sec-tz.minuteswest*60;
end;
Procedure InitEpochToLocal;
var
tv:TimeVal;
begin
GetTimeOfDay(tv,LocalTZ);
end;
Procedure EpochToLocal(epoch:longint;var year,month,day,hour,minute,second:Word);
{
Transforms Epoch time(seconds since 00:00, january 1 1970, corrected for
local time zone) into local time (hour, minute,seconds)
}
Var
DateNum: LongInt;
Begin { Beginning of Localtime }
dec(Epoch,LocalTZ.minuteswest*60);
Datenum:=(Epoch Div 86400) + c1970;
JulianToGregorian(DateNum,Year,Month,day);
Epoch:=Epoch Mod 86400;
Hour:=Epoch Div 3600;
Epoch:=Epoch Mod 3600;
Minute:=Epoch Div 60;
Second:=Epoch Mod 60;
End;
Function LocalToEpoch(year,month,day,hour,minute,second:Word):Longint;
{
Transforms local time (year,month,day,hour,minutes,second) to Epoch time
(seconds since 00:00, january 1 1970, corrected for local time zone)
}
Begin
LocalToEpoch:=((GregorianToJulian(Year,Month,Day)-c1970)*86400)+
(LongInt(Hour)*3600)+(Minute*60)+Second+(LocalTZ.minuteswest*60);
End;
Procedure GetTime(Var Hour,Minute,Second:Word);
{
Gets the current time, adjusted to local time, but not DST,
in hours, minutes and seconds.
}
var
year,day,month:Word;
Begin
EpochToLocal(GetTimeOfDay,year,month,day,hour,minute,second);
End;
Procedure GetDate(Var Year,Month,Day:Word);
{
Gets the current date, adjusted to local time, but not DST,
in year,month,day.
}
var
hour,minute,second : Word;
Begin
EpochToLocal(GetTimeOfDay,year,month,day,hour,minute,second);
End;
{ The now following are for compatibility with earlier versions
of the linux unit... }
Procedure EpochToLocal(epoch:longint;var year,month,day,hour,minute,second:Integer);
begin
EpochToLocal(epoch,word(year),word(month),word(day),word(hour),word(minute),word(second));
end;
Function LocalToEpoch(year,month,day,hour,minute,second:Integer):Longint;
begin
LocalToEpoch:=LocalToEpoch(word(year),word(month),word(day),word(hour),word(minute),word(second));
end;
Procedure GetTime(Var Hour,Minute,Second:Integer);
begin
GetTime(Word(Hour),Word(Minute),Word(Second));
end;
Procedure GetDate(Var Year,Month,Day:Integer);
begin
GetDate(Word(Year),Word(Month),Word(Day));
end;
{******************************************************************************
FileSystem calls
******************************************************************************}
Function fdOpen(pathname:string;flags:longint):longint;
begin
pathname:=pathname+#0;
fdOpen:=Sys_Open(@pathname[1],flags,0);
LinuxError:=Errno;
end;
Function fdOpen(pathname:string;flags,mode:longint):longint;
begin
pathname:=pathname+#0;
fdOpen:=Sys_Open(@pathname[1],flags,mode);
LinuxError:=Errno;
end;
Function fdOpen(pathname:pchar;flags:longint):longint;
begin
fdOpen:=Sys_Open(pathname,flags,0);
LinuxError:=Errno;
end;
Function fdOpen(pathname:pchar;flags,mode:longint):longint;
begin
fdOpen:=Sys_Open(pathname,flags,mode);
LinuxError:=Errno;
end;
Function fdClose(fd:longint):boolean;
begin
fdClose:=(Sys_Close(fd)=0);
LinuxError:=Errno;
end;
Function fdRead(fd:longint;var buf;size:longint):longint;
begin
fdRead:=Sys_Read(fd,pchar(@buf),size);
LinuxError:=Errno;
end;
Function fdWrite(fd:longint;var buf;size:longint):longint;
begin
fdWrite:=Sys_Write(fd,pchar(@buf),size);
LinuxError:=Errno;
end;
Function fdTruncate(fd,size:longint):boolean;
var
Regs : SysCallRegs;
begin
Regs.reg2:=fd;
Regs.reg3:=size;
fdTruncate:=(SysCall(Syscall_nr_ftruncate,regs)=0);
LinuxError:=Errno;
end;
Function fdSeek (fd,pos,seektype :longint): longint;
{
Do a Seek on a file descriptor fd to position pos, starting from seektype
}
begin
fdseek:=Sys_LSeek (fd,pos,seektype);
LinuxError:=Errno;
end;
Function fdFlush (fd : Longint) : Boolean;
var
SR: SysCallRegs;
begin
SR.reg2 := fd;
fdFlush := (SysCall(syscall_nr_fsync, SR)=0);
LinuxError:=Errno;
end;
Function Fcntl(Fd:Text;Cmd:integer):integer;
{
Read or manipulate a file.(See also fcntl (2) )
Possible values for Cmd are :
F_GetFd,F_GetFl,F_GetOwn
Errors are reported in Linuxerror;
If Cmd is different from the allowed values, linuxerror=Sys_eninval.
}
var
sr : Syscallregs;
begin
if (cmd in [F_GetFd,F_GetFl,F_GetOwn]) then
begin
sr.reg2:=textrec(fd).handle;
sr.reg3:=cmd;
Linuxerror:=SysCall(Syscall_nr_fcntl,sr);
if linuxerror=-1 then
begin
linuxerror:=errno;
fcntl:=0;
end
else
begin
fcntl:=linuxerror;
linuxerror:=0;
end;
end
else
begin
linuxerror:=Sys_einval;
Fcntl:=0;
end;
end;
Procedure Fcntl(Fd:Text;Cmd:Integer;Arg:Longint);
{
Read or manipulate a file. (See also fcntl (2) )
Possible values for Cmd are :
F_setFd,F_SetFl,F_GetLk,F_SetLk,F_SetLkW,F_SetOwn;
Errors are reported in Linuxerror;
If Cmd is different from the allowed values, linuxerror=Sys_eninval.
F_DupFD is not allowed, due to the structure of Files in Pascal.
}
var
sr : Syscallregs;
begin
if (cmd in [F_SetFd,F_SetFl,F_GetLk,F_SetLk,F_SetLkw,F_SetOwn]) then
begin
sr.reg2:=textrec(fd).handle;
sr.reg3:=cmd;
sr.reg4:=arg;
SysCall(Syscall_nr_fcntl,sr);
linuxerror:=errno;
end
else
linuxerror:=Sys_einval;
end;
Function Chmod(path:pathstr;Newmode:longint):Boolean;
{
Changes the permissions of a file.
}
var
sr : Syscallregs;
begin
path:=path+#0;
sr.reg2:=longint(@(path[1]));
sr.reg3:=newmode;
Chmod:=(SysCall(Syscall_nr_chmod,sr)=0);
linuxerror:=errno;
end;
Function Chown(path:pathstr;NewUid,NewGid:longint):boolean;
{
Change the owner and group of a file.
A user can only change the group to a group of which he is a member.
The super-user can change uid and gid of any file.
}
var
sr : Syscallregs;
begin
path:=path+#0;
sr.reg2:=longint(@(path[1]));
sr.reg3:=newuid;
sr.reg4:=newgid;
ChOwn:=(Syscall(Syscall_nr_chown,sr)=0);
linuxerror:=errno;
end;
Function Utime(path:pathstr;utim:utimbuf):boolean;
var
sr : Syscallregs;
begin
path:=path+#0;
sr.reg2:=longint(@(path[1]));
sr.reg3:=longint(@utim);
Utime:=SysCall(Syscall_nr_utime,sr)=0;
linuxerror:=errno;
end;
Function Flock (fd,mode : longint) : boolean;
var sr : Syscallregs;
begin
sr.reg2:=fd;
sr.reg3:=mode;
flock:=Syscall(Syscall_nr_flock,sr)=0;
LinuxError:=errno;
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 FStat(Path:Pathstr;Var Info:stat):Boolean;
{
Get all information on a file, and return it in Info.
}
begin
path:=path+#0;
FStat:=(Sys_stat(@(path[1]),Info)=0);
LinuxError:=errno;
end;
Function Fstat(Fd:Longint;var Info:stat):Boolean;
{
Get all information on a file descriptor, and return it in info.
}
var
regs : SysCallregs;
begin
regs.reg2:=Fd;
regs.reg3:=longint(@Info);
FStat:=(SysCall(SysCall_nr_fstat,regs)=0);
LinuxError:=Errno;
end;
Function FStat(var F:Text;Var Info:stat):Boolean;
{
Get all information on a text file, and return it in info.
}
begin
FStat:=Fstat(TextRec(F).Handle,INfo);
end;
Function FStat(var F:File;Var Info:stat):Boolean;
{
Get all information on a untyped file, and return it in info.
}
begin
FStat:=Fstat(FileRec(F).Handle,Info);
end;
Function Lstat(Filename: PathStr;var Info:stat):Boolean;
{
Get all information on a link (the link itself), and return it in info.
}
var
regs : SysCallregs;
begin
FileName:=FileName+#0;
regs.reg2:=longint(@filename[1]);
regs.reg3:=longint(@Info);
LStat:=(SysCall(SysCall_nr_lstat,regs)=0);
LinuxError:=Errno;
end;
Function FSStat(Path:Pathstr;Var Info:statfs):Boolean;
{
Get all information on a fileSystem, and return it in Info.
Path is the name of a file/directory on the fileSystem you wish to
investigate.
}
var
regs : SysCallregs;
begin
path:=path+#0;
regs.reg2:=longint(@path[1]);
regs.reg3:=longint(@Info);
FSStat:=(SysCall(SysCall_nr_statfs,regs)=0);
LinuxError:=errno;
end;
Function FSStat(Fd:Longint;Var Info:statfs):Boolean;
{
Get all information on a fileSystem, and return it in Info.
Fd is the file descriptor of a file/directory on the fileSystem
you wish to investigate.
}
var
regs : SysCallregs;
begin
regs.reg2:=Fd;
regs.reg3:=longint(@Info);
FSStat:=(SysCall(SysCall_nr_fstatfs,regs)=0);
LinuxError:=errno;
end;
Function Link(OldPath,NewPath:pathstr):boolean;
{
Proceduces a hard link from new to old.
In effect, new will be the same file as old.
}
var
regs : SysCallregs;
begin
oldpath:=oldpath+#0;
newpath:=newpath+#0;
regs.reg2:=longint(@oldpath[1]);
regs.reg3:=longint(@newpath[1]);
Link:=SysCall(SysCall_nr_link,regs)=0;
linuxerror:=errno;
end;
Function SymLink(OldPath,newPath:pathstr):boolean;
{
Proceduces a soft link from new to old.
}
begin
oldpath:=oldpath+#0;
newpath:=newpath+#0;
Symlink:=Sys_symlink(pchar(@(oldpath[1])),pchar(@(newpath[1])))=0;
linuxerror:=errno;
end;
Function UnLink(Path:pathstr):boolean;
{
Removes the file in 'Path' (that is, it decreases the link count with one.
if the link count is zero, the file is removed from the disk.
}
begin
path:=path+#0;
Unlink:=Sys_unlink(pchar(@(path[1])))=0;
linuxerror:=errno;
end;
Function UnLink(Path:pchar):Boolean;
{
Removes the file in 'Path' (that is, it decreases the link count with one.
if the link count is zero, the file is removed from the disk.
}
begin
Unlink:=(Sys_unlink(path)=0);
linuxerror:=errno;
end;
Function Umask(Mask:Integer):integer;
{
Sets file creation mask to (Mask and 0777 (octal) ), and returns the
previous value.
}
var
sr : Syscallregs;
begin
sr.reg2:=mask;
Umask:=SysCall(Syscall_nr_umask,sr);
linuxerror:=0;
end;
Function Access(Path:Pathstr ;mode:integer):boolean;
{
Test users access rights on the specified file.
Mode is a mask xosisting of one or more of R_OK, W_OK, X_OK, F_OK.
R,W,X stand for read,write and Execute access, simultaneously.
F_OK checks whether the test would be allowed on the file.
i.e. It checks the search permissions in all directory components
of the path.
The test is done with the real user-ID, instead of the effective.
If access is denied, or an error occurred, false is returned.
If access is granted, true is returned.
Errors other than no access,are reported in linuxerror.
}
var
sr : Syscallregs;
begin
path:=path+#0;
sr.reg2:=longint(@(path[1]));
sr.reg3:=mode;
access:=(SysCall(Syscall_nr_access,sr)=0);
linuxerror:=errno;
end;
Function Dup(oldfile,newfile:longint):Boolean;
{
Copies the filedescriptor oldfile to newfile
}
var
sr : Syscallregs;
begin
sr.reg2:=oldfile;
newfile:=Syscall(Syscall_nr_dup,sr);
linuxerror:=errno;
Dup:=(LinuxError=0);
end;
Function Dup(var oldfile,newfile:text):Boolean;
{
Copies the filedescriptor oldfile to newfile, after flushing the buffer of
oldfile.
After which the two textfiles are, in effect, the same, except
that they don't share the same buffer, and don't share the same
close_on_exit flag.
}
begin
flush(oldfile);{ We cannot share buffers, so we flush them. }
textrec(newfile):=textrec(oldfile);
textrec(newfile).bufptr:=@(textrec(newfile).buffer);{ No shared buffer. }
Dup:=Dup(textrec(oldfile).handle,textrec(newfile).handle);
end;
Function Dup(var oldfile,newfile:file):Boolean;
{
Copies the filedescriptor oldfile to newfile
}
begin
filerec(newfile):=filerec(oldfile);
Dup:=Dup(filerec(oldfile).handle,filerec(newfile).handle);
end;
Function Dup2(oldfile,newfile:longint):Boolean;
{
Copies the filedescriptor oldfile to newfile
}
var
sr : Syscallregs;
begin
sr.reg2:=oldfile;
sr.reg3:=newfile;
SysCall(Syscall_nr_dup2,sr);
linuxerror:=errno;
Dup2:=(LinuxError=0);
end;
Function Dup2(var oldfile,newfile:text):Boolean;
{
Copies the filedescriptor oldfile to newfile, after flushing the buffer of
oldfile. It closes newfile if it was still open.
After which the two textfiles are, in effect, the same, except
that they don't share the same buffer, and don't share the same
close_on_exit flag.
}
var
tmphandle : word;
begin
flush(oldfile);{ We cannot share buffers, so we flush them. }
flush(newfile);
tmphandle:=textrec(newfile).handle;
textrec(newfile):=textrec(oldfile);
textrec(newfile).handle:=tmphandle;
textrec(newfile).bufptr:=@(textrec(newfile).buffer);{ No shared buffer. }
Dup2:=Dup2(textrec(oldfile).handle,textrec(newfile).handle);
end;
Function Dup2(var oldfile,newfile:file):Boolean;
{
Copies the filedescriptor oldfile to newfile
}
begin
filerec(newfile):=filerec(oldfile);
Dup2:=Dup2(filerec(oldfile).handle,filerec(newfile).handle);
end;
Function Select(N:longint;readfds,writefds,exceptfds:PFDSet;TimeOut:PTimeVal):longint;
{
Select checks whether the file descriptor sets in readfs/writefs/exceptfs
have changed.
}
Var
SelectArray : Array[1..5] of longint;
Sr : Syscallregs;
begin
SelectArray[1]:=n;
SelectArray[2]:=longint(Readfds);
Selectarray[3]:=longint(Writefds);
selectarray[4]:=longint(exceptfds);
Selectarray[5]:=longint(TimeOut);
sr.reg2:=longint(@selectarray);
Select:=SysCall(Syscall_nr_select,sr);
LinuxError:=Errno;
end;
Function Select(N:longint;readfds,writefds,exceptfds:PFDSet;TimeOut:Longint):longint;
{
Select checks whether the file descriptor sets in readfs/writefs/exceptfs
have changed.
This function allows specification of a timeout as a longint.
}
var
p : PTimeVal;
tv : TimeVal;
begin
if TimeOut=-1 then
p:=nil
else
begin
tv.Sec:=Timeout div 1000;
tv.Usec:=(Timeout mod 1000)*1000;
p:=@tv;
end;
Select:=Select(N,Readfds,WriteFds,ExceptFds,p);
end;
Function SelectText(var T:Text;TimeOut :PTimeval):Longint;
Var
F:FDSet;
begin
if textrec(t).mode=fmclosed then
begin
LinuxError:=Sys_EBADF;
exit(-1);
end;
FD_Zero(f);
FD_Set(textrec(T).handle,f);
if textrec(T).mode=fminput then
SelectText:=select(textrec(T).handle+1,@f,nil,nil,TimeOut)
else
SelectText:=select(textrec(T).handle+1,nil,@f,nil,TimeOut);
end;
{******************************************************************************
Directory
******************************************************************************}
Function OpenDir(F:String):PDir;
begin
F:=F+#0;
OpenDir:=OpenDir(@F[1]);
end;
procedure SeekDir(p:pdir;off:longint);
begin
if p=nil then
begin
errno:=Sys_EBADF;
exit;
end;
p^.nextoff:=Sys_lseek(p^.fd,off,seek_set);
p^.size:=0;
p^.loc:=0;
end;
function TellDir(p:pdir):longint;
begin
if p=nil then
begin
errno:=Sys_EBADF;
telldir:=-1;
exit;
end;
telldir:=Sys_lseek(p^.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;
Function ReadDir(P:pdir):pdirent;
begin
ReadDir:=Sys_ReadDir(p);
LinuxError:=Errno;
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 : Sys_write(textrec(f).handle,pchar(textrec(f).bufptr),textrec(f).bufpos);
fminput : textrec(f).bufend:=Sys_read(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;
Sys_close(textrec(f).handle);
end;
Function AssignPipe(var pipe_in,pipe_out:longint):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
pip : tpipe;
regs : SysCallregs;
begin
regs.reg2:=longint(@pip);
SysCall(SysCall_nr_pipe,regs);
pipe_in:=pip[1];
pipe_out:=pip[2];
linuxerror:=errno;
AssignPipe:=(LinuxError=0);
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;
Function PClose(Var F:text) :longint;
var
sr : syscallregs;
pl : ^longint;
res : longint;
begin
flush (f);
sr.reg2:=Textrec(F).Handle;
SysCall (syscall_nr_close,sr);
{ closed our side, Now wait for the other - this appears to be needed ?? }
pl:=@(textrec(f).userdata[2]);
waitpid(pl^,@res,0);
pclose:=res shr 8;
end;
Function PClose(Var F:file) : longint;
var
sr : syscallregs;
pl : ^longint;
res : longint;
begin
sr.reg2:=FileRec(F).Handle;
SysCall (Syscall_nr_close,sr);
{ closed our side, Now wait for the other - this appears to be needed ?? }
pl:=@(filerec(f).userdata[2]);
waitpid(pl^,@res,0);
pclose:=res shr 8;
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:=Sys_enoent;
exit;
end;
AssignPipe(pipi,pipo);
if Linuxerror<>0 then
exit;
pid:=fork;
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);
dup2(pipi,input);
close(pipi);
if linuxerror<>0 then
halt(127);
end
else
begin
close(pipi);
dup2(pipo,output);
close(pipo);
if linuxerror<>0 then
halt(127);
end;
pp:=createshellargv(prog);
Execve(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:=Sys_enoent;
exit;
end;
AssignPipe(pipi,pipo);
if Linuxerror<>0 then
exit;
pid:=fork;
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);
dup2(filerec(pipi).handle,stdinputhandle);
close(pipi);
if linuxerror<>0 then
halt(127);
end
else
begin
close(pipi);
dup2(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;
pp^:=@temp[1];
p:=pp+sizeof(pchar);
p^:=@temp[9];
p:=p+sizeof(pchar);
p^:=@temp[12];
p:=p+sizeof(pchar);
p^:=Nil;
Execve('/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 mkFifo(pathname:string;mode:longint):boolean;
var
regs : SysCallRegs;
begin
pathname:=pathname+#0;
regs.reg2:=longint(@pathname[1]);
regs.reg3:=mode or STAT_IFIFO;
regs.reg4:=0;
mkFifo:=(SysCall(syscall_nr_mknod,regs)=0);
end;
Procedure AssignStream(Var StreamIn,Streamout:text;Const Prog:String);
{
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
}
var
pipi,
pipo : text;
pid : longint;
begin
LinuxError:=0;
AssignPipe(streamin,pipo);
if Linuxerror<>0 then
exit;
AssignPipe(pipi,streamout);
if Linuxerror<>0 then
exit;
pid:=fork;
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);
dup2(pipi,input);
if linuxerror<>0 then
halt(127);
close(pipi);
dup2(pipo,output);
if linuxerror<>0 then
halt (127);
close(pipo);
Execl(Prog);
halt(127);
end
else
begin
{ we're in the parent}
{
Let's redraw the schedule :
Parent Child
pipo[1] --> pipi[1]
pipi[0] <-- pipo[0]
}
close(pipo);
// dup(pipi[0],streamin);
// close (pipi[0]);
close(pipi);
// dup(pipo[1],streamout);
// close (pipo[1]);
end;
end;
{******************************************************************************
General information calls
******************************************************************************}
Function Sysinfo(var Info:TSysinfo):Boolean;
{
Get system info
}
var
regs : SysCallregs;
Begin
regs.reg2:=longint(@info);
Sysinfo:=SysCall(SysCall_nr_Sysinfo,regs)=0;
End;
Function Uname(var unamerec:utsname):Boolean;
{
Get machine's names
}
var
regs : SysCallregs;
Begin
regs.reg2:=longint(@unamerec);
Uname:=SysCall(SysCall_nr_uname,regs)=0;
LinuxError:=Errno;
End;
Function GetEnv(P:string):Pchar;
{
Searches the environment for a string with name p and
returns a pchar to it's value.
A pchar is used to accomodate for strings of length > 255
}
var
ep : ppchar;
found : boolean;
Begin
p:=p+'='; {Else HOST will also find HOSTNAME, etc}
ep:=envp;
found:=false;
while (not found) and (ep^<>nil) do
begin
if strlcomp(@p[1],(ep^),length(p))=0 then
found:=true
else
ep:=ep+4;
end;
if found then
getenv:=ep^+length(p)
else
getenv:=nil;
end;
Function GetDomainName:String;
{
Get machines domain name. Returns empty string if not set.
}
Var
Sysn : utsname;
begin
Uname(Sysn);
linuxerror:=errno;
If linuxerror<>0 then
getdomainname:=''
else
getdomainname:=strpas(@Sysn.domainname[0]);
end;
Function GetHostName:String;
{
Get machines name. Returns empty string if not set.
}
Var
Sysn : utsname;
begin
uname(Sysn);
linuxerror:=errno;
If linuxerror<>0 then
gethostname:=''
else
gethostname:=strpas(@Sysn.nodename[0]);
end;
{******************************************************************************
Signal handling calls
******************************************************************************}
Function Kill(Pid:longint;Sig:integer):integer;
{
Send signal 'sig' to a process, or a group of processes.
If Pid > 0 then the signal is sent to pid
pid=-1 to all processes except process 1
pid < -1 to process group -pid
Return value is zero, except for case three, where the return value
is the number of processes to which the signal was sent.
}
var
regs : Syscallregs;
begin
regs.reg2:=Pid;
regs.reg3:=Sig;
kill:=SysCall(Syscall_nr_kill,regs);
if kill<0 then
Kill:=0;
linuxerror:=errno;
end;
Procedure SigAction(Signum:Integer;Var Act,OldAct:PSigActionRec );
{
Change action of process upon receipt of a signal.
Signum specifies the signal (all except SigKill and SigStop).
If Act is non-nil, it is used to specify the new action.
If OldAct is non-nil the previous action is saved there.
}
Var
sr : Syscallregs;
begin
sr.reg2:=Signum;
sr.reg3:=Longint(act);
sr.reg4:=Longint(oldact);
SysCall(Syscall_nr_sigaction,sr);
linuxerror:=errno;
end;
Procedure SigProcMask(How:Integer;SSet,OldSSet:PSigSet);
{
Change the list of currently blocked signals.
How determines which signals will be blocked :
SigBlock : Add SSet to the current list of blocked signals
SigUnBlock : Remove the signals in SSet from the list of blocked signals.
SigSetMask : Set the list of blocked signals to SSet
if OldSSet is non-null, the old set will be saved there.
}
Var
sr : SyscallRegs;
begin
sr.reg2:=how;
sr.reg3:=longint(SSet);
sr.reg4:=longint(OldSSet);
SysCall(Syscall_nr_sigprocmask,sr);
linuxerror:=errno;
end;
Function SigPending:SigSet;
{
Allows examination of pending signals. The signal mask of pending
signals is set in SSet
}
Var
sr : SyscallRegs;
dummy : Sigset;
begin
sr.reg2:=longint(@dummy);
SysCall(Syscall_nr_sigpending,sr);
linuxerror:=errno;
Sigpending:=dummy;
end;
Procedure SigSuspend(Mask:Sigset);
{
Set the signal mask with Mask, and suspend the program until a signal
is received.
}
Var
sr : SyscallRegs;
begin
sr.reg2:=mask;
SysCall(Syscall_nr_sigsuspend,sr);
linuxerror:=errno;
end;
Function Signal(Signum:Integer;Handler:PSignalHandler):PSignalHandler;
{
Install a new handler for signal Signum.
The old signal handler is returned.
This call does, in fact, the same as SigAction.
}
var
sr : Syscallregs;
begin
sr.reg2:=signum;
sr.reg3:=longint(handler);
Linuxerror:=SysCall(Syscall_nr_signal,sr);
If linuxerror=Sig_Err then
begin
Signal:=nil;
Linuxerror:=errno;
end
else
begin
Signal:=pointer(Linuxerror);
linuxerror:=0;
end;
end;
{******************************************************************************
IOCtl and Termios calls
******************************************************************************}
Function IOCtl(Handle,Ndx: Longint;Data: Pointer):boolean;
{
Interface to Unix ioctl call.
Performs various operations on the filedescriptor Handle.
Ndx describes the operation to perform.
Data points to data needed for the Ndx function. The structure of this
data is function-dependent.
}
var
sr: SysCallRegs;
begin
sr.reg2:=Handle;
sr.reg3:=Ndx;
sr.reg4:=Longint(Data);
IOCtl:=(SysCall(Syscall_nr_ioctl,sr)=0);
LinuxError:=Errno;
end;
Function TCGetAttr(fd:longint;var tios:TermIOS):boolean;
begin
TCGetAttr:=IOCtl(fd,TCGETS,@tios);
end;
Function TCSetAttr(fd:longint;OptAct:longint;var tios:TermIOS):boolean;
var
nr:longint;
begin
case OptAct of
TCSANOW : nr:=TCSETS;
TCSADRAIN : nr:=TCSETSW;
TCSAFLUSH : nr:=TCSETSF;
else
begin
ErrNo:=Sys_EINVAL;
TCSetAttr:=false;
exit;
end;
end;
TCSetAttr:=IOCtl(fd,nr,@Tios);
end;
Procedure CFSetISpeed(var tios:TermIOS;speed:Longint);
begin
tios.c_cflag:=(tios.c_cflag and (not CBAUD)) or speed;
end;
Procedure CFSetOSpeed(var tios:TermIOS;speed:Longint);
begin
CFSetISpeed(tios,speed);
end;
Procedure CFMakeRaw(var tios:TermIOS);
begin
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;
end;
Function TCSendBreak(fd,duration:longint):boolean;
begin
TCSendBreak:=IOCtl(fd,TCSBRK,pointer(duration));
end;
Function TCSetPGrp(fd,id:longint):boolean;
begin
TCSetPGrp:=IOCtl(fd,TIOCSPGRP,pointer(id));
end;
Function TCGetPGrp(fd:longint;var id:longint):boolean;
begin
TCGetPGrp:=IOCtl(fd,TIOCGPGRP,@id);
end;
Function TCDrain(fd:longint):boolean;
begin
TCDrain:=IOCtl(fd,TCSBRK,pointer(1));
end;
Function TCFlow(fd,act:longint):boolean;
begin
TCFlow:=IOCtl(fd,TCXONC,pointer(act));
end;
Function TCFlush(fd,qsel:longint):boolean;
begin
TCFlush:=IOCtl(fd,TCFLSH,pointer(qsel));
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.
}
Const
dev='/dev';
var
name : string;
st : stat;
mydev,
myino : longint;
dirstream : pdir;
d : pdirent;
begin
TTYName:='';
fstat(handle,st);
if (errno<>0) and isatty (handle) then
exit;
mydev:=st.dev;
myino:=st.ino;
dirstream:=opendir(dev);
if (linuxerror<>0) then
exit;
d:=Readdir(dirstream);
while (d<>nil) do
begin
if (d^.ino=myino) then
begin
name:=dev+'/'+strpas(@(d^.name));
fstat(name,st);
if (linuxerror=0) and (st.dev=mydev) then
begin
closedir(dirstream);
ttyname:=name;
exit;
end;
end;
d:=Readdir(dirstream);
end;
closedir(dirstream);
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;
Function StringToPPChar(Var S:STring):ppchar;
{
Create a PPChar to structure of pchars which are the arguments specified
in the string S. Especially usefull for creating an ArgV for Exec-calls
}
var
nr : longint;
Buf : ^char;
p : ppchar;
begin
s:=s+#0;
buf:=@s[1];
nr:=0;
while(buf^<>#0) do
begin
while (buf^ in [' ',#8,#10]) do
buf:=buf+1;
inc(nr);
while not (buf^ in [' ',#0,#8,#10]) do
buf:=buf+1;
end;
getmem(p,nr*4);
StringToPPChar:=p;
if p=nil then
begin
LinuxError:=sys_enomem;
exit;
end;
buf:=@s[1];
while (buf^<>#0) do
begin
while (buf^ in [' ',#8,#10]) do
begin
buf^:=#0;
buf:=buf+1;
end;
p^:=buf;
p:=p+4;
p^:=nil;
while not (buf^ in [' ',#0,#8,#10]) do
buf:=buf+1;
end;
end;
Function FExpand(Const Path:PathStr):PathStr;
var
temp : pathstr;
i,j : longint;
p : pchar;
Begin
{Remove eventual drive - doesn't exist in Linux}
if path[2]=':' then
i:=3
else
i:=1;
temp:='';
{Replace ~/ with $HOME}
if (path[i]='~') and ((i+1>length(path)) or (path[i+1]='/')) then
begin
p:=getenv('HOME');
if not (p=nil) then
Insert(StrPas(p),temp,i);
i:=1;
temp:=temp+Copy(Path,2,255);
end;
{Do we have an absolute path ? No - prefix the current dir}
if temp='' then
begin
if path[i]<>'/' then
getdir(0,temp)
else
inc(i);
temp:=temp+'/'+copy(path,i,length(path)-i+1)+'/';
end;
{First remove all references to '/./'}
while pos('/./',temp)<>0 do
delete(temp,pos('/./',temp),2);
{Now remove also all references to '/../' + of course previous dirs..}
repeat
i:=pos('/../',temp);
{Find the pos of the previous dir}
if i>1 then
begin
j:=i-1;
while (j>1) and (temp[j]<>'/') do
dec (j);{temp[1] is always '/'}
delete(temp,j,i-j+3);
end
else
if i=1 then {i=1, so we have temp='/../something', just delete '/../'}
delete(temp,1,3);
until i=0;
{Remove ending . and / which may exist}
if (length(temp)>0) and (temp[length(temp)]='/') then
dec(byte(temp[0]));
fexpand:=temp;
End;
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 FStat(NewDir,Info) 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 FSplit(const Path:PathStr;Var Dir:DirStr;Var Name:NameStr;Var Ext:ExtStr);
Var
DotPos,SlashPos,i : longint;
Begin
SlashPos:=0;
DotPos:=256;
i:=Length(Path);
While (i>0) and (SlashPos=0) Do
Begin
If (DotPos=256) and (Path[i]='.') Then
DotPos:=i;
If (Path[i]='/') Then
SlashPos:=i;
Dec(i);
End;
Ext:=Copy(Path,DotPos,255);
Dir:=Copy(Path,1,SlashPos);
Name:=Copy(Path,SlashPos + 1,DotPos - SlashPos - 1);
End;
Function Dirname(Const path:pathstr):pathstr;
{
This function returns the directory part of a complete path.
Unless the directory is root '/', The last character is not
a slash.
}
var
Dir,Name,Ext : string;
begin
FSplit(Path,Dir,Name,Ext);
if length(Dir)>1 then
Delete(Dir,length(Dir),1);
DirName:=Dir;
end;
Function Basename(Const path:pathstr;Const suf:pathstr):pathstr;
{
This function returns the filename part of a complete path. If suf is
supplied, it is cut off the filename.
}
var
Dir,Name,Ext : string;
begin
FSplit(Path,Dir,Name,Ext);
if Suf<>Ext then
Name:=Name+Ext;
BaseName:=Name;
end;
Function FNMatch(const Pattern,Name:string):Boolean;
Var
LenPat,LenName : longint;
Function DoFNMatch(i,j:longint):Boolean;
Var
Found : boolean;
Begin
Found:=true;
While Found and (i<=LenPat) Do
Begin
Case Pattern[i] of
'?' : Found:=(j<=LenName);
'*' : Begin
{find the next character in pattern, different of ? and *}
while Found and (i<LenPat) do
begin
inc(i);
case Pattern[i] of
'*' : ;
'?' : begin
inc(j);
Found:=(j<=LenName);
end;
else
Found:=false;
end;
end;
{Now, find in name the character which i points to, if the * or ?
wasn't the last character in the pattern, else, use up all the
chars in name}
Found:=true;
if (i<=LenPat) then
begin
repeat
{find a letter (not only first !) which maches pattern[i]}
while (j<=LenName) and (name[j]<>pattern[i]) do
inc (j);
if (j<LenName) then
begin
if DoFnMatch(i+1,j+1) then
begin
i:=LenPat;
j:=LenName;{we can stop}
Found:=true;
end
else
inc(j);{We didn't find one, need to look further}
end;
until (j>=LenName);
end
else
j:=LenName;{we can stop}
end;
else {not a wildcard character in pattern}
Found:=(j<=LenName) and (pattern[i]=name[j]);
end;
inc(i);
inc(j);
end;
DoFnMatch:=Found and (j>LenName);
end;
Begin {start FNMatch}
LenPat:=Length(Pattern);
LenName:=Length(Name);
FNMatch:=DoFNMatch(1,1);
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 p<>nil do
begin
temp:=p^.next;
if p^.name<>nil then
freemem(p^.name,strlen(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 : string[255];
thedir : pdir;
buffer : pdirent;
root,run : pglob;
begin
{ Get directory }
if dirname(path)='' then
temp:='.'
else
temp:=dirname(path);
temp:=temp+#0;
thedir:=opendir(@temp[1]);
if thedir=nil then
begin
glob:=nil;
linuxerror:=errno;
exit;
end;
temp:=basename(path,'');{ get the pattern }
if thedir^.fd<0 then
begin
linuxerror:=errno;
glob:=nil;
exit;
end;
{get the entries}
new(root);
run:=root;
repeat
buffer:=Sys_readdir(thedir);
if buffer<>nil then
begin
if fnmatch(temp,strpas(@(buffer^.name[0]))) then
begin
{ get memory for pglob }
new(run^.next);
if run^.next=nil then
begin
linuxerror:=Sys_ENOMEM;
globfree(root);
glob:=nil;
exit;
end
else
begin
run:=run^.next;
run^.next:=nil;
end;
{ Get memory for name }
getmem(run^.name,strlen(@(buffer^.name[0]))+1);
if run^.name=nil then
begin
linuxerror:=Sys_ENOMEM;
globfree(root);
glob:=nil;
exit;
end;
move(buffer^.name[0],run^.name^,strlen(@(buffer^.name[0]))+1);
end;{ if fnmatch }
end { buffer <> nil }
else
begin
run:=root;
if root^.next<>nil then
root:=root^.next;{ put root on first entry}
if run<>nil then
begin
run^.next:=nil;
globfree(run);
end;
end;
until buffer=nil;
if root^.name=nil then
begin
dispose(root);
linuxerror:=0;
glob:=nil;
end
else
glob:=root;
end;
{--------------------------------
FiledescriptorSets
--------------------------------}
Procedure FD_Zero(var fds:fdSet);
{
Clear the set of filedescriptors
}
begin
FillChar(fds,sizeof(fdSet),0);
end;
Procedure FD_Clr(fd:longint;var fds:fdSet);
{
Remove fd from the set of filedescriptors
}
begin
fds[fd shr 5]:=fds[fd shr 5] and (not (1 shl (fd and 31)));
end;
Procedure FD_Set(fd:longint;var fds:fdSet);
{
Add fd to the set of filedescriptors
}
begin
fds[fd shr 5]:=fds[fd shr 5] or (1 shl (fd and 31));
end;
Function FD_IsSet(fd:longint;var fds:fdSet):boolean;
{
Test if fd is part of the set of filedescriptors
}
begin
FD_IsSet:=((fds[fd shr 5] and (1 shl (fd and 31)))<>0);
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
--------------------------------}
Function S_ISLNK(m:integer):boolean;
{
Check mode field of inode for link.
}
begin
S_ISLNK:=(m and STAT_IFMT)=STAT_IFLNK;
end;
Function S_ISREG(m:integer):boolean;
{
Check mode field of inode for regular file.
}
begin
S_ISREG:=(m and STAT_IFMT)=STAT_IFREG;
end;
Function S_ISDIR(m:integer):boolean;
{
Check mode field of inode for directory.
}
begin
S_ISDIR:=(m and STAT_IFMT)=STAT_IFDIR;
end;
Function S_ISCHR(m:integer):boolean;
{
Check mode field of inode for character device.
}
begin
S_ISCHR:=(m and STAT_IFMT)=STAT_IFCHR;
end;
Function S_ISBLK(m:integer):boolean;
{
Check mode field of inode for block device.
}
begin
S_ISBLK:=(m and STAT_IFMT)=STAT_IFBLK;
end;
Function S_ISFIFO(m:integer):boolean;
{
Check mode field of inode for named pipe (FIFO).
}
begin
S_ISFIFO:=(m and STAT_IFMT)=STAT_IFIFO;
end;
Function S_ISSOCK(m:integer):boolean;
{
Check mode field of inode for socket.
}
begin
S_ISSOCK:=(m and STAT_IFMT)=STAT_IFSOCK;
end;
{--------------------------------
Port IO functions
--------------------------------}
Function IOperm (From,Num : Cardinal; Value : Longint) : boolean;
{
Set permissions on NUM ports starting with port FROM to VALUE
this works ONLY as root.
}
Var Sr : Syscallregs;
begin
Sr.Reg2:=From;
Sr.Reg3:=Num;
Sr.Reg4:=Value;
IOPerm:=Syscall(Syscall_nr_ioperm,sr)=0;
LinuxError:=Errno;
end;
Procedure WritePort (Port : Longint; Value : Byte);
{
Writes 'Value' to port 'Port'
}
begin
asm
movl 8(%ebp),%edx
movb 12(%ebp),%al
outb %al,%dx
end;
end;
Procedure WritePort (Port : Longint; Value : Word);
{
Writes 'Value' to port 'Port'
}
begin
asm
movl 8(%ebp),%edx
movw 12(%ebp),%ax
outw %ax,%dx
end ['EAX','EBX'];
end;
Procedure WritePort (Port : Longint; Value : Longint);
{
Writes 'Value' to port 'Port'
}
begin
asm
movl 8(%ebp),%edx
movl 12(%ebp),%eax
outl %eax,%dx
end ['EAX','EBX'];
end;
Procedure WritePortl (Port : Longint; Var Buf; Count: longint);
{
Writes 'Count' longints from 'Buf' to Port
}
begin
asm
movl 16(%ebp),%ecx
movl 12(%ebp),%esi
movl 8(%ebp),%edx
cld
rep
outsl
end ['ECX','ESI','EDX'];
end;
Procedure WritePortW (Port : Longint; Var Buf; Count: longint);
{
Writes 'Count' words from 'Buf' to Port
}
begin
asm
movl 16(%ebp),%ecx
movl 12(%ebp),%esi
movl 8(%ebp),%edx
cld
rep
outsw
end ['ECX','ESI','EDX'];
end;
Procedure WritePortB (Port : Longint; Var Buf; Count: longint);
{
Writes 'Count' bytes from 'Buf' to Port
}
begin
asm
movl 16(%ebp),%ecx
movl 12(%ebp),%esi
movl 8(%ebp),%edx
cld
rep
outsb
end ['ECX','ESI','EDX'];
end;
Procedure ReadPort (Port : Longint; Var Value : Byte);
{
Reads 'Value' from port 'Port'
}
begin
asm
movl 8(%ebp),%edx
inb %dx,%al
andl $255,%eax
movl %eax,12(%ebp)
end ['EAX','EBX'];
end;
Procedure ReadPort (Port : Longint; Var Value : Word);
{
Reads 'Value' from port 'Port'
}
begin
asm
movl 8(%ebp),%edx
inw %dx,%ax
andl $65535,%eax
movl %eax,12(%ebp)
end ['EAX','EBX'];
end;
Procedure ReadPort (Port : Longint; Var Value : Longint);
{
Reads 'Value' from port 'Port'
}
begin
asm
movl 8(%ebp),%edx
inl %dx,%eax
movl %eax,12(%ebp)
end ['EAX','EBX'];
end;
Procedure ReadPortL (Port : Longint; Var Buf; Count: longint);
{
Reads 'Count' longints from port 'Port' to 'Buf'.
}
begin
asm
movl 16(%ebp),%ecx
movl 12(%ebp),%edi
movl 8(%ebp),%edx
cld
rep
insl
end ['ECX','ESI','EDX'];
end;
Procedure ReadPortW (Port : Longint; Var Buf; Count: longint);
{
Reads 'Count' words from port 'Port' to 'Buf'.
}
begin
asm
movl 16(%ebp),%ecx
movl 12(%ebp),%edi
movl 8(%ebp),%edx
cld
rep
insw
end ['ECX','ESI','EDX'];
end;
Procedure ReadPortB (Port : Longint; Var Buf; Count: longint);
{
Reads 'Count' bytes from port 'Port' to 'Buf'.
}
begin
asm
movl 16(%ebp),%ecx
movl 12(%ebp),%edi
movl 8(%ebp),%edx
cld
rep
insb
end ['ECX','ESI','EDX'];
end;
Begin
InitEpochToLocal;
End.
{
$Log$
Revision 1.10 1998-06-16 08:21:58 michael
* PClose didn't flush textfiles before closing. Now it does
Revision 1.9 1998/06/03 11:55:33 michael
+ Added IO port calls
Revision 1.8 1998/05/06 18:45:32 peter
* fixed the shell() bug (the correct code was also in Popen) moved the
argv generation to CreateShellArgv
+ Execve with pchar instead of string
Revision 1.7 1998/05/06 12:35:26 michael
+ Removed log from before restored version.
Revision 1.6 1998/04/15 11:23:53 michael
+ Added some calls to make common API more efficient
Revision 1.5 1998/04/10 15:23:03 michael
+ Pclose now returns exit status of process
Revision 1.4 1998/04/07 13:08:29 michael
+ Added flock for file locking
Revision 1.3 1998/04/07 12:27:41 peter
* fixed fexpand('..')
Revision 1.2 1998/04/04 17:07:17 michael
+ Fixed AssignStream, it completely refused to work
}
Reference in New Issue View Git Blame Copy Permalink