Support for relative symlink creation

1 files changed, 35 insertions, 0 deletions

diff --git a/UCoreUtils.pas b/UCoreUtils.pas
index 7a5a6b1..fa89eea 100644
--- a/UCoreUtils.pas
+++ b/UCoreUtils.pas
@@ -115,6 +115,9 @@ function Min(Val1, Val2: longint): longint;
 
 function XORStr(const s: string; Key: byte): string;
 
+function FindCommonRoot(BasePath, DestPath: string): string;
+function BuildRelativePath(BasePath, DestPath: string): string;
+
 procedure ReportGTKVersion;
 
 //  Internal locking
@@ -1591,6 +1594,38 @@ begin
 end;
 
 (********************************************************************************************************************************)
+function FindCommonRoot(BasePath, DestPath: string): string;
+var i, LastSlash: integer;
+begin
+  LastSlash := 0;
+  for i := 1 to Min(Length(BasePath), Length(DestPath)) do
+    if BasePath[i] = DestPath[i] then begin
+      if IsPathDelimiter(BasePath, i)
+        then LastSlash := i;
+    end else Break;
+  if (LastSlash) <= 0 then Result := ''
+                      else Result := Copy(BasePath, 1, LastSlash);
+end;
+
+function BuildRelativePath(BasePath, DestPath: string): string;
+var CommonRoot, RestSrc, RestDst: string;
+    SlashPos: integer;
+begin
+  CommonRoot := FindCommonRoot(BasePath, DestPath);
+  RestSrc := Copy(BasePath, Length(CommonRoot) + 1, Length(BasePath) - Length(CommonRoot));
+  RestDst := Copy(DestPath, Length(CommonRoot) + 1, Length(DestPath) - Length(CommonRoot));
+
+  Result := '';
+  SlashPos := Pos(PathDelim, RestDst);
+  while (SlashPos > 0) do begin
+    Result := Result + '../';
+    Delete(RestDst, 1, SlashPos);
+    SlashPos := Pos(PathDelim, RestDst);
+  end;
+  Result := Result + RestSrc;
+end;
+
+(********************************************************************************************************************************)
 
 procedure signal_proc(signal_number: integer); cdecl;
 var {pid,} status: integer;