mirror of
https://github.com/nim-lang/Nim.git
synced 2026-01-03 03:32:32 +00:00
621 lines
14 KiB
ObjectPascal
621 lines
14 KiB
ObjectPascal
//
|
|
//
|
|
// The Nimrod Compiler
|
|
// (c) Copyright 2009 Andreas Rumpf
|
|
//
|
|
// See the file "copying.txt", included in this
|
|
// distribution, for details about the copyright.
|
|
//
|
|
unit nos;
|
|
|
|
// This module provides Nimrod's os module in Pascal
|
|
// Note: Only implement what is really needed here!
|
|
|
|
interface
|
|
|
|
{$include 'config.inc'}
|
|
|
|
uses
|
|
sysutils,
|
|
{$ifdef mswindows}
|
|
windows,
|
|
{$else}
|
|
dos,
|
|
unix,
|
|
{$endif}
|
|
strutils,
|
|
nsystem;
|
|
|
|
type
|
|
EOSError = class(exception)
|
|
end;
|
|
|
|
TSplitFileResult = record
|
|
dir, name, ext: string;
|
|
end;
|
|
TSplitPathResult = record
|
|
head, tail: string;
|
|
end;
|
|
|
|
const
|
|
curdir = '.';
|
|
{$ifdef mswindows}
|
|
dirsep = '\'; // seperator within paths
|
|
altsep = '/';
|
|
exeExt = 'exe';
|
|
{$else}
|
|
dirsep = '/';
|
|
altsep = #0; // work around fpc bug
|
|
exeExt = '';
|
|
{$endif}
|
|
pathSep = ';'; // seperator between paths
|
|
sep = dirsep; // alternative name
|
|
extsep = '.';
|
|
|
|
function executeShellCommand(const cmd: string): int;
|
|
// like exec, but gets a command
|
|
|
|
function FileNewer(const a, b: string): Boolean;
|
|
// returns true if file a is newer than file b
|
|
// i.e. a was modified before b
|
|
// if a or b does not exist returns false
|
|
|
|
function getEnv(const name: string): string;
|
|
procedure putEnv(const name, val: string);
|
|
|
|
function JoinPath(const head, tail: string): string; overload;
|
|
function JoinPath(const parts: array of string): string; overload;
|
|
|
|
procedure SplitPath(const path: string; out head, tail: string); overload;
|
|
|
|
function extractDir(const f: string): string;
|
|
function extractFilename(const f: string): string;
|
|
|
|
function getApplicationDir(): string;
|
|
function getApplicationFilename(): string;
|
|
|
|
function getCurrentDir: string;
|
|
function GetConfigDir(): string;
|
|
|
|
|
|
procedure SplitFilename(const filename: string; out name, extension: string);
|
|
|
|
function ExistsFile(const filename: string): Boolean;
|
|
function AddFileExt(const filename, ext: string): string;
|
|
function ChangeFileExt(const filename, ext: string): string;
|
|
|
|
procedure createDir(const dir: string);
|
|
function expandFilename(filename: string): string;
|
|
|
|
function UnixToNativePath(const path: string): string;
|
|
|
|
function sameFile(const path1, path2: string): boolean;
|
|
|
|
|
|
function extractFileTrunk(const filename: string): string;
|
|
|
|
function splitFile(const path: string): TSplitFileResult;
|
|
function splitPath(const path: string): TSplitPathResult; overload;
|
|
|
|
|
|
implementation
|
|
|
|
function splitFile(const path: string): TSplitFileResult;
|
|
var
|
|
sepPos, dotPos, i: int;
|
|
begin
|
|
if (path = '') or (path[length(path)] in [dirSep, altSep]) then begin
|
|
result.dir := path;
|
|
result.name := '';
|
|
result.ext := '';
|
|
end
|
|
else begin
|
|
sepPos := 0;
|
|
dotPos := length(path)+1;
|
|
for i := length(path) downto 1 do begin
|
|
if path[i] = ExtSep then begin
|
|
if (dotPos = length(path)+1) and (i > 1) then dotPos := i
|
|
end
|
|
else if path[i] in [dirsep, altsep] then begin
|
|
sepPos := i; break
|
|
end
|
|
end;
|
|
result.dir := ncopy(path, 1, sepPos-1);
|
|
result.name := ncopy(path, sepPos+1, dotPos-1);
|
|
result.ext := ncopy(path, dotPos)
|
|
end
|
|
end;
|
|
|
|
function extractFileTrunk(const filename: string): string;
|
|
var
|
|
f, e, dir: string;
|
|
begin
|
|
splitPath(filename, dir, f);
|
|
splitFilename(f, result, e);
|
|
end;
|
|
|
|
function GetConfigDir(): string;
|
|
begin
|
|
{$ifdef windows}
|
|
result := getEnv('APPDATA') + '\';
|
|
{$else}
|
|
result := getEnv('HOME') + '/.config/';
|
|
{$endif}
|
|
end;
|
|
|
|
function getCurrentDir: string;
|
|
begin
|
|
result := sysutils.GetCurrentDir();
|
|
end;
|
|
|
|
function UnixToNativePath(const path: string): string;
|
|
begin
|
|
if dirSep <> '/' then
|
|
result := replace(path, '/', dirSep)
|
|
else
|
|
result := path;
|
|
end;
|
|
|
|
function expandFilename(filename: string): string;
|
|
begin
|
|
result := sysutils.expandFilename(filename)
|
|
end;
|
|
|
|
function sameFile(const path1, path2: string): boolean;
|
|
begin
|
|
result := cmpIgnoreCase(expandFilename(UnixToNativePath(path1)),
|
|
expandFilename(UnixToNativePath(path2))) = 0;
|
|
end;
|
|
|
|
procedure createDir(const dir: string);
|
|
var
|
|
i: int;
|
|
begin
|
|
for i := 2 to length(dir) do begin
|
|
if dir[i] in [sep, altsep] then sysutils.createDir(ncopy(dir, 1, i-1));
|
|
end;
|
|
sysutils.createDir(dir);
|
|
end;
|
|
|
|
function searchExtPos(const s: string): int;
|
|
var
|
|
i: int;
|
|
begin
|
|
result := -1;
|
|
for i := length(s) downto 2 do
|
|
if s[i] = extsep then begin
|
|
result := i;
|
|
break
|
|
end
|
|
else if s[i] in [dirsep, altsep] then break
|
|
end;
|
|
|
|
function normExt(const ext: string): string;
|
|
begin
|
|
if (ext = '') or (ext[1] = extSep) then
|
|
result := ext // no copy needed here
|
|
else
|
|
result := extSep + ext
|
|
end;
|
|
|
|
function AddFileExt(const filename, ext: string): string;
|
|
var
|
|
extPos: int;
|
|
begin
|
|
extPos := searchExtPos(filename);
|
|
if extPos < 0 then
|
|
result := filename + normExt(ext)
|
|
else
|
|
result := filename
|
|
end;
|
|
|
|
function ChangeFileExt(const filename, ext: string): string;
|
|
var
|
|
extPos: int;
|
|
begin
|
|
extPos := searchExtPos(filename);
|
|
if extPos < 0 then
|
|
result := filename + normExt(ext)
|
|
else
|
|
result := ncopy(filename, strStart, extPos-1) + normExt(ext)
|
|
end;
|
|
|
|
procedure SplitFilename(const filename: string; out name, extension: string);
|
|
var
|
|
extPos: int;
|
|
begin
|
|
extPos := searchExtPos(filename);
|
|
if extPos > 0 then begin
|
|
name := ncopy(filename, 1, extPos-1);
|
|
extension := ncopy(filename, extPos);
|
|
end
|
|
else begin
|
|
name := filename;
|
|
extension := ''
|
|
end
|
|
end;
|
|
|
|
procedure SplitPath(const path: string; out head, tail: string);
|
|
var
|
|
sepPos, i: int;
|
|
begin
|
|
sepPos := 0;
|
|
for i := length(path) downto 1 do
|
|
if path[i] in [sep, altsep] then begin
|
|
sepPos := i;
|
|
break
|
|
end;
|
|
if sepPos > 0 then begin
|
|
head := ncopy(path, 1, sepPos-1);
|
|
tail := ncopy(path, sepPos+1)
|
|
end
|
|
else begin
|
|
head := '';
|
|
tail := path
|
|
end
|
|
end;
|
|
|
|
function SplitPath(const path: string): TSplitPathResult;
|
|
begin
|
|
SplitPath(path, result.head, result.tail);
|
|
end;
|
|
|
|
function getApplicationFilename(): string;
|
|
{$ifdef darwin}
|
|
var
|
|
tail: string;
|
|
p: int;
|
|
paths: TStringSeq;
|
|
begin
|
|
// little heuristic that may works on Mac OS X:
|
|
result := ParamStr(0); // POSIX guaranties that this contains the executable
|
|
// as it has been executed by the calling process
|
|
if (length(result) > 0) and (result[1] <> '/') then begin
|
|
// not an absolute path?
|
|
// iterate over any path in the $PATH environment variable
|
|
paths := split(getEnv('PATH'), [':']);
|
|
for p := 0 to high(paths) do begin
|
|
tail := joinPath(paths[p], result);
|
|
if ExistsFile(tail) then begin result := tail; exit end
|
|
end
|
|
end
|
|
end;
|
|
{$else}
|
|
begin
|
|
result := ParamStr(0);
|
|
end;
|
|
{$endif}
|
|
|
|
function getApplicationDir(): string;
|
|
begin
|
|
result := extractDir(getApplicationFilename());
|
|
end;
|
|
|
|
function extractDir(const f: string): string;
|
|
var
|
|
tail: string;
|
|
begin
|
|
SplitPath(f, result, tail)
|
|
end;
|
|
|
|
function extractFilename(const f: string): string;
|
|
var
|
|
head: string;
|
|
begin
|
|
SplitPath(f, head, result);
|
|
end;
|
|
|
|
function JoinPath(const head, tail: string): string;
|
|
begin
|
|
if head = '' then
|
|
result := tail
|
|
else if head[length(head)] in [sep, altsep] then
|
|
if (tail <> '') and (tail[1] in [sep, altsep]) then
|
|
result := head + ncopy(tail, 2)
|
|
else
|
|
result := head + tail
|
|
else
|
|
if (tail <> '') and (tail[1] in [sep, altsep]) then
|
|
result := head + tail
|
|
else
|
|
result := head + sep + tail
|
|
end;
|
|
|
|
function JoinPath(const parts: array of string): string;
|
|
var
|
|
i: int;
|
|
begin
|
|
result := parts[0];
|
|
for i := 1 to high(parts) do
|
|
result := JoinPath(result, parts[i])
|
|
end;
|
|
|
|
{$ifdef mswindows}
|
|
function getEnv(const name: string): string;
|
|
var
|
|
len: Cardinal;
|
|
begin
|
|
// get the length:
|
|
len := windows.GetEnvironmentVariable(PChar(name), nil, 0);
|
|
if len = 0 then
|
|
result := ''
|
|
else begin
|
|
setLength(result, len-1);
|
|
windows.GetEnvironmentVariable(PChar(name), @result[1], len);
|
|
end
|
|
end;
|
|
|
|
procedure putEnv(const name, val: string);
|
|
begin
|
|
windows.SetEnvironmentVariable(PChar(name), PChar(val));
|
|
end;
|
|
|
|
function GetDateStr: string;
|
|
var
|
|
st: SystemTime;
|
|
begin
|
|
Windows.GetLocalTime({$ifdef fpc} @ {$endif} st);
|
|
result := IntToStr(st.wYear, 4) + '/' + IntToStr(st.wMonth, 2) + '/'
|
|
+ IntToStr(st.wDay, 2)
|
|
end;
|
|
|
|
procedure GetDate(var Day, Month, Year: int);
|
|
var
|
|
st: SystemTime;
|
|
begin
|
|
Windows.GetLocalTime({$ifdef fpc} @ {$endif} st);
|
|
Day := st.wDay;
|
|
Month := st.wMonth;
|
|
Year := st.wYear
|
|
end;
|
|
|
|
procedure GetTime(var Hours, Minutes, Seconds, Millisec: int);
|
|
var
|
|
st: SystemTime;
|
|
begin
|
|
Windows.GetLocalTime({$ifdef fpc} @ {$endif} st);
|
|
Hours := st.wHour;
|
|
Minutes := st.wMinute;
|
|
Seconds := st.wSecond;
|
|
Millisec := st.wMilliseconds
|
|
end;
|
|
{$else} // not windows
|
|
|
|
function setenv(var_name, new_value: PChar;
|
|
change_flag: Boolean): Integer; cdecl; external 'libc';
|
|
|
|
type
|
|
TPair = record
|
|
key, val: string;
|
|
end;
|
|
TPairs = array of TPair;
|
|
var
|
|
myEnv: TPairs; // this is a horrible fix for Posix systems!
|
|
|
|
function getMyEnvIdx(const key: string): int;
|
|
var
|
|
i: int;
|
|
begin
|
|
for i := 0 to high(myEnv) do
|
|
if myEnv[i].key = key then begin result := i; exit end;
|
|
result := -1
|
|
end;
|
|
|
|
function getMyEnv(const key: string): string;
|
|
var
|
|
i: int;
|
|
begin
|
|
i := getMyEnvIdx(key);
|
|
if i >= 0 then result := myEnv[i].val
|
|
else result := ''
|
|
end;
|
|
|
|
procedure setMyEnv(const key, val: string);
|
|
var
|
|
i: int;
|
|
begin
|
|
i := getMyEnvIdx(key);
|
|
if i < 0 then begin
|
|
i := length(myEnv);
|
|
setLength(myEnv, i+1);
|
|
myEnv[i].key := key
|
|
end;
|
|
myEnv[i].val := val
|
|
end;
|
|
|
|
procedure putEnv(const name, val: string);
|
|
begin
|
|
setEnv(pchar(name), pchar(val), true);
|
|
setMyEnv(name, val);
|
|
// writeln('putEnv() is not supported under this OS');
|
|
// halt(3);
|
|
end;
|
|
|
|
function getEnv(const name: string): string;
|
|
begin
|
|
result := getMyEnv(name);
|
|
if result = '' then result := dos.getEnv(name);
|
|
end;
|
|
|
|
function GetDateStr: string;
|
|
var
|
|
wMonth, wYear, wDay: Word;
|
|
begin
|
|
SysUtils.DecodeDate(Date, wYear, wMonth, wDay);
|
|
result := IntToStr(wYear, 4) + '/' + IntToStr(wMonth, 2) + '/'
|
|
+ IntToStr(wDay, 2)
|
|
end;
|
|
|
|
procedure GetDate(var Day, Month, Year: int);
|
|
var
|
|
wMonth, wYear, wDay: Word;
|
|
begin
|
|
SysUtils.DecodeDate(Date, wYear, wMonth, wDay);
|
|
Day := wDay;
|
|
Month := wMonth;
|
|
Year := wYear
|
|
end;
|
|
|
|
procedure GetTime(var Hours, Minutes, Seconds, Millisec: int);
|
|
var
|
|
wHour, wMin, wSec, wMSec: Word;
|
|
begin
|
|
SysUtils.DecodeTime(Time, wHour, wMin, wSec, wMSec);
|
|
Hours := wHour; Minutes := wMin; Seconds := wSec; Millisec := wMSec;
|
|
end;
|
|
{$endif}
|
|
|
|
function GetTimeStr: string;
|
|
var
|
|
Hour, Min, Sec, MSec: int;
|
|
begin
|
|
GetTime(Hour, min, sec, msec);
|
|
result := IntToStr(Hour, 2) + ':' + IntToStr(min, 2) + ':' + IntToStr(Sec, 2)
|
|
end;
|
|
|
|
function DateAndTime: string;
|
|
begin
|
|
result := GetDateStr() + ' ' + getTimeStr()
|
|
end;
|
|
|
|
{$ifdef windows}
|
|
|
|
function executeShellCommand(const cmd: string): int;
|
|
var
|
|
SI: TStartupInfo;
|
|
ProcInfo: TProcessInformation;
|
|
process: THandle;
|
|
L: DWORD;
|
|
begin
|
|
FillChar(SI, Sizeof(SI), 0);
|
|
SI.cb := SizeOf(SI);
|
|
SI.hStdError := GetStdHandle(STD_ERROR_HANDLE);
|
|
SI.hStdInput := GetStdHandle(STD_INPUT_HANDLE);
|
|
SI.hStdOutput := GetStdHandle(STD_OUTPUT_HANDLE);
|
|
if not Windows.CreateProcess(nil, PChar(cmd), nil, nil, false,
|
|
NORMAL_PRIORITY_CLASS, nil {Windows.GetEnvironmentStrings()},
|
|
nil, SI, ProcInfo)
|
|
then
|
|
result := getLastError()
|
|
else begin
|
|
Process := ProcInfo.hProcess;
|
|
CloseHandle(ProcInfo.hThread);
|
|
if WaitForSingleObject(Process, INFINITE) <> $ffffffff then begin
|
|
GetExitCodeProcess(Process, L);
|
|
result := int(L)
|
|
end
|
|
else
|
|
result := -1;
|
|
CloseHandle(Process);
|
|
end;
|
|
end;
|
|
|
|
{$else}
|
|
{$ifdef windows}
|
|
function executeShellCommand(const cmd: string): int;
|
|
begin
|
|
result := dos.Exec(cmd, '')
|
|
end;
|
|
//C:\Eigenes\compiler\MinGW\bin;
|
|
{$else}
|
|
// fpc has a portable function for this
|
|
function executeShellCommand(const cmd: string): int;
|
|
begin
|
|
result := shell(cmd);
|
|
end;
|
|
{$endif}
|
|
{$endif}
|
|
|
|
{$ifdef windows}
|
|
type
|
|
TFileAge = packed record
|
|
Low, High: Longword;
|
|
end;
|
|
{$else}
|
|
type
|
|
TFileAge = dos.DateTime;
|
|
{DateTime = packed record
|
|
Year: Word;
|
|
Month: Word;
|
|
Day: Word;
|
|
Hour: Word;
|
|
Min: Word;
|
|
Sec: Word;
|
|
end;}
|
|
{$endif}
|
|
|
|
function GetLastWriteTime(Filename: PChar): TFileAge;
|
|
{$ifdef windows}
|
|
var
|
|
Handle: THandle;
|
|
FindRec: Win32_Find_Data;
|
|
begin
|
|
Handle := FindFirstFile(Filename, FindRec);
|
|
FindClose(Handle);
|
|
result := TFileAge(FindRec.ftLastWriteTime)
|
|
end;
|
|
{$else}
|
|
var
|
|
f: file;
|
|
time: longint;
|
|
begin
|
|
AssignFile(f, AnsiString(Filename));
|
|
Reset(f);
|
|
GetFTime(f, time);
|
|
unpackTime(time, result);
|
|
CloseFile(f);
|
|
end;
|
|
{$endif}
|
|
|
|
function Newer(file1, file2: PChar): Boolean;
|
|
var
|
|
Time1, Time2: TFileAge;
|
|
begin
|
|
Time1 := GetLastWriteTime(file1);
|
|
Time2 := GetLastWriteTime(file2);
|
|
{$ifdef windows}
|
|
if Time1.High <> Time2.High then
|
|
result := Time1.High > Time2.High
|
|
else
|
|
result := Time1.Low > Time2.Low
|
|
{$else}
|
|
if time1.year <> time2.year then
|
|
result := time1.year > time2.year
|
|
else if time1.month <> time2.month then
|
|
result := time1.month > time2.month
|
|
else if time1.day <> time2.day then
|
|
result := time1.day > time2.day
|
|
else if time1.hour <> time2.hour then
|
|
result := time1.hour > time2.hour
|
|
else if time1.min <> time2.min then
|
|
result := time1.min > time2.min
|
|
else if time1.sec <> time2.sec then
|
|
result := time1.sec > time2.sec
|
|
{$endif}
|
|
end;
|
|
|
|
{$ifopt I+} {$define I_on} {$I-} {$endif}
|
|
function ExistsFile(const filename: string): Boolean;
|
|
var
|
|
txt: TextFile;
|
|
begin
|
|
AssignFile(txt, filename);
|
|
Reset(txt);
|
|
if IOResult = 0 then begin
|
|
result := true;
|
|
CloseFile(txt)
|
|
end
|
|
else result := false
|
|
end;
|
|
{$ifdef I_on} {$I+} {$endif}
|
|
|
|
function FileNewer(const a, b: string): Boolean;
|
|
begin
|
|
if not ExistsFile(PChar(a)) or not ExistsFile(PChar(b)) then
|
|
result := false
|
|
else
|
|
result := newer(PChar(a), PChar(b))
|
|
end;
|
|
|
|
end.
|