mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-31 22:11:12 +01:00
442 lines
12 KiB
ObjectPascal
442 lines
12 KiB
ObjectPascal
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1999-2000 by the Free Pascal development team
|
|
|
|
<What does this file>
|
|
|
|
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 unixutil;
|
|
|
|
interface
|
|
|
|
var
|
|
Tzseconds : Longint;
|
|
|
|
Type
|
|
ComStr = String[255];
|
|
PathStr = String[255];
|
|
DirStr = String[255];
|
|
NameStr = String[255];
|
|
ExtStr = String[255];
|
|
|
|
Function Dirname(Const path:pathstr):pathstr;
|
|
Function StringToPPChar(S: PChar;ReserveEntries:integer):ppchar;
|
|
Function StringToPPChar(Var S:String;ReserveEntries:integer):ppchar;
|
|
Function StringToPPChar(Var S:AnsiString;ReserveEntries:integer):ppchar;
|
|
function ArrayStringToPPchar(const S:Array of AnsiString;reserveentries:Longint):ppchar; // const ?
|
|
Function Basename(Const path:pathstr;Const suf:pathstr):pathstr;
|
|
Function FNMatch(const Pattern,Name:string):Boolean;
|
|
Function GetFS (var T:Text):longint;
|
|
Function GetFS(Var F:File):longint;
|
|
Procedure FSplit(const Path:PathStr;Var Dir:DirStr;Var Name:NameStr;Var Ext:ExtStr);
|
|
Function LocalToEpoch(year,month,day,hour,minute,second:Word):Longint;
|
|
Procedure EpochToLocal(epoch:longint;var year,month,day,hour,minute,second:Word);
|
|
Procedure JulianToGregorian(JulianDN:LongInt;Var Year,Month,Day:Word);
|
|
Function GregorianToJulian(Year,Month,Day:Longint):LongInt;
|
|
|
|
implementation
|
|
|
|
{$I textrec.inc}
|
|
{$i filerec.inc}
|
|
|
|
function ArrayStringToPPchar(const S:Array of AnsiString;reserveentries:Longint):ppchar; // const ?
|
|
// Extra allocate reserveentries pchar's at the beginning (default param=0 after 1.0.x ?)
|
|
// Note: for internal use by skilled programmers only
|
|
// if "s" goes out of scope in the parent procedure, the pointer is dangling.
|
|
|
|
var p : ppchar;
|
|
Res,
|
|
i : LongInt;
|
|
begin
|
|
if High(s)<Low(s) Then Exit(NIL);
|
|
Getmem(p,sizeof(pchar)*(high(s)-low(s)+ReserveEntries+2)); // one more for NIL, one more
|
|
// for cmd
|
|
if p=nil then
|
|
begin
|
|
{$ifdef xunix}
|
|
fpseterrno(ESysEnomem);
|
|
{$endif}
|
|
exit(NIL);
|
|
end;
|
|
for i:=low(s) to high(s) do
|
|
p[i+Reserveentries]:=pchar(s[i]);
|
|
p[high(s)+1+Reserveentries]:=nil;
|
|
ArrayStringToPPchar:=p;
|
|
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
|
|
begin
|
|
DotPos:=i;
|
|
end;
|
|
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 : PathStr;
|
|
Name : NameStr;
|
|
Ext : ExtStr;
|
|
begin
|
|
FSplit(Path,Dir,Name,Ext);
|
|
if length(Dir)>1 then
|
|
Delete(Dir,length(Dir),1);
|
|
DirName:=Dir;
|
|
end;
|
|
|
|
Function StringToPPChar(Var S:String;ReserveEntries:integer):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
|
|
Note that the string S is destroyed by this call.
|
|
}
|
|
|
|
begin
|
|
S:=S+#0;
|
|
StringToPPChar:=StringToPPChar(pchar(@S[1]),ReserveEntries);
|
|
end;
|
|
|
|
Function StringToPPChar(Var S:AnsiString;ReserveEntries:integer):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
|
|
}
|
|
|
|
begin
|
|
StringToPPChar:=StringToPPChar(PChar(S),ReserveEntries);
|
|
end;
|
|
|
|
Function StringToPPChar(S: PChar;ReserveEntries:integer):ppchar;
|
|
|
|
var
|
|
i,nr : longint;
|
|
Buf : ^char;
|
|
p : ppchar;
|
|
InQuote : Boolean;
|
|
|
|
begin
|
|
buf:=s;
|
|
nr:=1;
|
|
InQuote:=false;
|
|
while (buf^<>#0) do // count nr of args
|
|
begin
|
|
while (buf^ in [' ',#9,#10]) do // Kill separators.
|
|
inc(buf);
|
|
inc(nr);
|
|
if buf^='"' Then // quotes argument?
|
|
begin
|
|
inc(buf);
|
|
while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote
|
|
inc(buf);
|
|
if buf^='"' then // skip closing quote.
|
|
inc(buf);
|
|
end
|
|
else
|
|
begin // else std
|
|
while not (buf^ in [' ',#0,#9,#10]) do
|
|
inc(buf);
|
|
end;
|
|
end;
|
|
getmem(p,(ReserveEntries+nr)*sizeof(pchar));
|
|
StringToPPChar:=p;
|
|
if p=nil then
|
|
begin
|
|
{$ifdef xunix}
|
|
fpseterrno(ESysEnomem);
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
for i:=1 to ReserveEntries do inc(p); // skip empty slots
|
|
buf:=s;
|
|
while (buf^<>#0) do
|
|
begin
|
|
while (buf^ in [' ',#9,#10]) do // Kill separators.
|
|
begin
|
|
buf^:=#0;
|
|
inc(buf);
|
|
end;
|
|
if buf^='"' Then // quotes argument?
|
|
begin
|
|
inc(buf);
|
|
p^:=buf;
|
|
inc(p);
|
|
p^:=nil;
|
|
while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote
|
|
inc(buf);
|
|
if buf^='"' then // skip closing quote.
|
|
begin
|
|
buf^:=#0;
|
|
inc(buf);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
p^:=buf;
|
|
inc(p);
|
|
p^:=nil;
|
|
while not (buf^ in [' ',#0,#9,#10]) do
|
|
inc(buf);
|
|
end;
|
|
end;
|
|
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 : PathStr;
|
|
Name : NameStr;
|
|
Ext : ExtStr;
|
|
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 do
|
|
begin
|
|
inc(i);
|
|
if i>LenPat then Break;
|
|
case Pattern[i] of
|
|
'*' : ;
|
|
'?' : begin
|
|
if j>LenName then begin DoFNMatch:=false; Exit; end;
|
|
inc(j);
|
|
end;
|
|
else
|
|
Found:=false;
|
|
end;
|
|
end;
|
|
Assert((i>LenPat) or ( (Pattern[i]<>'*') and (Pattern[i]<>'?') ));
|
|
{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:=false;
|
|
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;
|
|
Break;
|
|
end else
|
|
inc(j);{We didn't find one, need to look further}
|
|
end else
|
|
if j=LenName then
|
|
begin
|
|
Found:=true;
|
|
Break;
|
|
end;
|
|
{ This 'until' condition must be j>LenName, not j>=LenName.
|
|
That's because when we 'need to look further' and
|
|
j = LenName then loop must not terminate. }
|
|
until (j>LenName);
|
|
end else
|
|
begin
|
|
j:=LenName;{we can stop}
|
|
Found:=true;
|
|
end;
|
|
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;
|
|
|
|
|
|
|
|
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;
|
|
|
|
Const
|
|
{Date Translation}
|
|
C1970=2440588;
|
|
D0 = 1461;
|
|
D1 = 146097;
|
|
D2 =1721119;
|
|
|
|
|
|
Procedure JulianToGregorian(JulianDN:LongInt;Var Year,Month,Day:Word);
|
|
Var
|
|
YYear,XYear,Temp,TempMonth : 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;
|
|
TempMonth:=Temp Div 153;
|
|
If TempMonth>=10 Then
|
|
Begin
|
|
inc(YYear);
|
|
dec(TempMonth,12);
|
|
End;
|
|
inc(TempMonth,3);
|
|
Month := TempMonth;
|
|
Year:=YYear+(JulianDN*100);
|
|
end;
|
|
|
|
Procedure EpochToLocal(epoch:longint;var year,month,day,hour,minute,second:Word);
|
|
{
|
|
Transforms Epoch time into local time (hour, minute,seconds)
|
|
}
|
|
Var
|
|
DateNum: LongInt;
|
|
Begin
|
|
inc(Epoch,TZSeconds);
|
|
Datenum:=(Epoch Div 86400) + c1970;
|
|
JulianToGregorian(DateNum,Year,Month,day);
|
|
Epoch:=Abs(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)+(Longint(Minute)*60)+Second-TZSeconds;
|
|
End;
|
|
|
|
|
|
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;
|
|
|
|
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.6 2004-06-12 13:48:08 michael
|
|
+ Patch from Michalis Kamburelis for FNMatch
|
|
|
|
revision 1.5
|
|
date: 2004/03/15 20:43:07; author: peter; state: Exp; lines: +1 -1
|
|
* fix memory allocation in stringtoppchar
|
|
|
|
revision 1.4
|
|
date: 2004/02/13 10:50:23; author: marco; state: Exp; lines: +80 -22
|
|
* Hopefully last large changes to fpexec and friends.
|
|
- naming conventions changes from Michael.
|
|
- shell functions get alternative under ifdef.
|
|
- arraystring function moves to unixutil
|
|
- unixutil now regards quotes in stringtoppchar.
|
|
- sysutils/unix get executeprocess(ansi,array of ansi), and
|
|
both executeprocess functions are fixed
|
|
- Sysutils/win32 get executeprocess(ansi,array of ansi)
|
|
|
|
revision 1.3
|
|
date: 2003/11/03 09:42:28; author: marco; state: Exp; lines: +3 -3
|
|
* Peter's Cardinal<->Longint fixes patch
|
|
|
|
revision 1.2
|
|
date: 2003/09/17 19:07:44; author: marco; state: Exp; lines: +80 -0
|
|
* more fixes for Unix<->unixutil
|
|
|
|
revision 1.1
|
|
date: 2003/09/17 17:24:45; author: marco; state: Exp;
|
|
* Initial version. Plain vanilla copy and paste from unix.pp
|
|
} |