[Lazarus] CreateRelativePath document error.

[Paul van Helden]

Hi Juha,

FPC RTL comes with ExtractRelativePath. I still use my own code because 
Delphi's didn't work properly either. It seems FPC's ExtractRelativePath 
is much shorter than mine. If someone can confirm it works well that 
would be great (no time now to test thoroughly).

I use the following code (comes from Delphi but with some changes). The 
second function is to expand a relative path. I don't know how you can 
have one without the other, but then I probably don't know where to look 
for it.

function ExtractRelativePath(const BaseName, DestName: string): string;
var
   BasePath, DestPath: string;
   BaseLead, DestLead: PChar;
   BasePtr, DestPtr: PChar;

   function ExtractFilePathNoDrive(const FileName: string): string;
   begin
     Result := ExtractFilePath(FileName);
     Delete(Result, 1, Length(ExtractFileDrive(FileName)));
   end;

   function Next(var Lead: PChar): PChar;
   begin
     Result := Lead;
     if Result = nil then Exit;
     Lead := AnsiStrScan(Lead, PathDelim);
     if Lead <> nil then
     begin
       Lead^ := #0;
       Inc(Lead);
     end;
   end;

begin
   if SameFilename(ExtractFileDrive(BaseName), 
ExtractFileDrive(DestName)) then
   begin
     BasePath := ExtractFilePathNoDrive(BaseName);
     DestPath := ExtractFilePathNoDrive(DestName);
     BaseLead := PChar(BasePath);
     BasePtr := Next(BaseLead);
     DestLead := Pointer(DestPath);
     DestPtr := Next(DestLead);
     while (BasePtr <> nil) and (DestPtr <> nil) and 
SameFilename(BasePtr, DestPtr) do
     begin
       BasePtr := Next(BaseLead);
       DestPtr := Next(DestLead);
     end;
     Result := '';
     while BaseLead <> nil do
     begin
       Result := Result + '..' + PathDelim;
       Next(BaseLead);
     end;
     if (DestPtr <> nil) and (DestPtr^ <> #0) then
       Result := Result + DestPtr + PathDelim;
     if DestLead <> nil then
       Result := Result + DestLead;     // destlead already has a 
trailing backslash
     Result := Result + ExtractFileName(DestName);
     if Result='' then Result:='.';
   end
   else
     Result := DestName;
end;

function ExpandRelativePath(const BaseName, DestName: String): String;
var
   BasePath, DestPath: string;
   BaseDirs, DestDirs: array[0..129] of PChar;
   BaseDirCount, DestDirCount: Integer;
   I, J: Integer;

   function ExtractFilePathNoDrive(const FileName: string): string;
   begin
     Result := ExtractFilePath(FileName);
     Result := Copy(Result, Length(ExtractFileDrive(FileName)) + 1, 32767);
   end;

   procedure SplitDirs(var Path: string; var Dirs: array of PChar;
     var DirCount: Integer);
   var
     I, J, L: Integer;
   begin
     I := 1;
     J := 0;
     L := Length(Path);
     while (I<=L) and (Path[I] in LeadBytes) do Inc(I);
     if I<=L then
     begin
       if Path[I] = PathDelim then
       begin
         Path[I] := #0;
         Dirs[J] := @Path[I + 1];
         Inc(J);
       end
       else
       begin
         Dirs[J] := @Path[I];
         Inc(J);
       end;
       Inc(I);
     end;
     while I<=L do
     begin
       if Path[I] = PathDelim then
       begin
         Path[I] := #0;
         Dirs[J] := @Path[I + 1];
         Inc(J);
       end;
       Inc(I);
     end;
     DirCount := J - 1;
   end;

begin
   if (DestName='.') or (DestName='') then Result:=ExtractFilePath(BaseName)
   else if ExtractFileDrive(DestName)='' then
   begin
     if DestName[1]=PathDelim then 
Result:=ExtractFileDrive(BaseName)+DestName
     else
     begin
       BasePath := ExtractFilePathNoDrive(BaseName);
       DestPath := ExtractFilePathNoDrive(DestName);
       SplitDirs(BasePath, BaseDirs, BaseDirCount);
       SplitDirs(DestPath, DestDirs, DestDirCount);
       I:=0;
       while (I<DestDirCount) and (StrComp(DestDirs[I], '..')=0) do Inc(I);
       Result := '';
       for J := 0 to BaseDirCount-I-1 do
         Result := Result + BaseDirs[J] + PathDelim;
       for J := I to DestDirCount - 1 do
         Result := Result + DestDirs[J] + PathDelim;
       Result:=Result+ExtractFileName(DestName);
     end;
   end
   else Result := DestName;
end;

Regards,

Paul.