function TryCreateRelativePath(const Dest, Source: String; UsePointDirectory: boolean;
AlwaysRequireSharedBaseFolder: Boolean; out RelPath: String): Boolean;
Const
MaxDirs = 129;
Type
TDirArr = Array[1..MaxDirs] of String;
function SplitDirs(Dir: String; out Dirs: TDirArr): Integer;
var
Start, Stop, Len: Integer;
S: String;
begin
Result := 0;
Len := Length(Dir);
if (Len = 0) then Exit;
Start := 1;
Stop := 1;
While Start <= Len do
begin
if (Dir[Start] in AllowDirectorySeparators) then
begin
S := Copy(Dir,Stop,Start-Stop);
//ignore empty strings, they are caused by double PathDelims, which we just ignore
if (S <> '') then
begin
Inc(Result);
if Result>High(Dirs) then
raise Exception.Create('too many sub directories');
Dirs[Result] := S;
end;
Stop := Start + 1;
end;
Inc(Start);
end;
//If (Len > 0) then
S := Copy(Dir,Stop,Start-Stop);
if (S <> '') then
begin
Inc(Result);
Dirs[Result] := S;
end;
end;
var
CompareFunc: function(const Item1, Item2: String): PtrInt;
SourceRoot, DestRoot, CmpDest, CmpSource: String;
CmpDestLen, CmpSourceLen, DestCount, SourceCount, i,
SharedFolders, LevelsBack, LevelsUp: Integer;
SourceDirs, DestDirs: Array[1..MaxDirs] of String;
IsAbs: Boolean;
begin
Result := False;
if (Dest = '') or (Source = '') then Exit;
if (Pos('..',Dest) > 0) or (Pos('..',Source) > 0) then Exit;
SourceRoot := ExtractFileRoot(Source);
DestRoot := ExtractFileRoot(Dest);
//debugln('TryCreaterelativePath: DestRoot = "',DestRoot,'"');
//debugln('TryCreaterelativePath: SourceRoot = "',SourceRoot,'"');
//Root must be same: either both absolute filenames or both relative (and on same drive in Windows)
if (CompareFileNames(SourceRoot, DestRoot) <> 0) then Exit;
IsAbs := (DestRoot <> '');
{$if defined(windows) and not defined(wince)}
if not IsAbs then // relative paths
begin
//we cannot handle files like c:foo
if ((Length(Dest) > 1) and (UpCase(Dest[1]) in ['A'..'Z']) and (Dest[2] = ':')) or
((Length(Source) > 1) and (UpCase(Source[1]) in ['A'..'Z']) and (Source[2] = ':')) then Exit;
//we cannot handle combinations like dest=foo source=\bar or the other way around
if ((Dest[1] in AllowDirectorySeparators) and not (Source[1] in AllowDirectorySeparators)) or
(not (Dest[1] in AllowDirectorySeparators) and (Source[1] in AllowDirectorySeparators)) then Exit;
end;
{$endif}
{$IFDEF CaseInsensitiveFilenames}
CompareFunc := @UTF8CompareText;
{$else CaseInsensitiveFilenames}
CompareFunc := @Utf8CompareStr;
{$endif CaseInsensitiveFilenames}
CmpSource := Source;
CmpDest := Dest;
{$IFDEF darwin}
CmpSource := GetDarwinSystemFilename(CmpSource);
CmpDest := GetDarwinSystemFilename(CmpDest);
{$ENDIF}
CmpDest := ChompPathDelim(Dest);
CmpSource := ChompPathDelim(Source);
if IsAbs then
begin
System.Delete(CmpSource,1,Length(SourceRoot));
System.Delete(CmpDest,1,Length(DestRoot));
end;
//Get rid of excessive trailing PathDelims now after (!) we stripped Root
while (Length(CmpDest) > 0) and (CmpDest[Length(CmpDest)] in AllowDirectorySeparators) do System.Delete(CmpDest,Length(CmpDest),1);
while (Length(CmpSource) > 0) and (CmpSource[Length(CmpSource)] in AllowDirectorySeparators) do System.Delete(CmpSource,Length(CmpSource),1);
//debugln('TryCreaterelativePath: CmpDest = "',cmpdest,'"');
//debugln('TryCreaterelativePath: CmpSource = "',cmpsource,'"');
CmpDestLen := Length(CmpDest);
CmpSourceLen := Length(CmpSource);
DestCount := SplitDirs(CmpDest, DestDirs);
SourceCount := SplitDirs(CmpSource, SourceDirs);
//debugln('TryCreaterelativePath: DestDirs:');
//for i := 1 to DestCount do debugln(DbgS(i),' "',DestDirs[i],'"'); debugln;
//debugln('TryCreaterelativePath:');
//for i := 1 to SourceCount do debugln(DbgS(i),' "',SourceDirs[i],'"'); debugln;
i := 1;
SharedFolders := 0;
while (i <= DestCount) and (i <= SourceCount) do
begin
if (CompareFunc(DestDirs[i], SourceDirs[i]) = 0) then
begin
Inc(SharedFolders);
Inc(i);
end
else
begin
Break;
end;
end;
//debugln('TryCreaterelativePath: SharedFolders = ',DbgS(SharedFolders));
if (SharedFolders = 0) and ((not IsAbs) or AlwaysRequireSharedBaseFolder) and not ((CmpDestLen = 0) or (CmpSourceLen = 0)) then
begin
//debguln('TryCreaterelativePath: FAIL: IsAbs = ',DbgS(IsAs),' AlwaysRequireSharedBaseFolder = ',DbgS(AlwaysRequireSharedBaseFolder),
//' SharedFolders = 0, CmpDestLen = ',DbgS(cmpdestlen),' CmpSourceLen = ',DbgS(CmpSourceLen));
Exit;
end;
LevelsBack := SourceCount - SharedFolders;
LevelsUp := DestCount - SharedFolders;
//debugln('TryCreaterelativePath: LevelsBack = ',DbgS(Levelsback));
//debugln('TryCreaterelativePath: LevelsUp = ',DbgS(LevelsUp));
if (LevelsBack > 0) then
begin
RelPath := '';
for i := 1 to LevelsBack do RelPath := '..' + PathDelim + Relpath;
for i := LevelsUp downto 1 do
begin
if (RelPath <> '') and not (RelPath[Length(RelPath)] in AllowDirectorySeparators) then RelPath := RelPath + PathDelim;
RelPath := RelPath + DestDirs[DestCount + 1 - i];
end;
RelPath := ChompPathDelim(RelPath);
end
else
begin
RelPath := '';
for i := LevelsUp downto 1 do
begin
if (RelPath <> '') then RelPath := RelPath + PathDelim;
RelPath := RelPath + DestDirs[DestCount + 1 - i];
end;
end;
if UsePointDirectory and (RelPath = '') then
RelPath := '.'; // Dest = Source
Result := True;
end;