CreateRelativePath doesn't like too many dots.
lazarus / 64-FPC development

----------------------------------------------------------------------
heribertB · 2017-08-17 16:17

Hi,

I think I've detected a bug in CreateRelativePath. Simple sample code
to illustrate:

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i writeln (
CreateRelativePath ( 'D:\D .....  .....\1\2\3\4.txt' , 'D:\D .....
 .....\1' ) ) ; writeln ( CreateRelativePath ( 'D:\D aaaaa
 aaaaa\1\2\3\4.txt' , 'D:\D aaaaa  aaaaa\1' ) ) ;
results:

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i D:\D .....
 .....\1\2\3\4.txt2\3\4.txt
So, without dots, it works, with dots, it doesn't. I haven't checked
the source yet (lack of time), but maybe someone has an idea?

Cheerio

Heribert

----------------------------------------------------------------------
Bart · 2017-08-17 17:14

There's a similar function in LazFileUtils IIRC.
You can try that.

Bart

----------------------------------------------------------------------
Handoko · 2019-10-01 03:12

Sorry for posting on an old thread.

I can reproduce the issue on Lazarus 2.0.4 FPC 3.0.4 GTK2 Linux
64-bit. Inspecting the source of lazfileutils.inc (function
TryCreateRelativePath), I found that line #318 is the cause of the
issue:
  if (Pos('..',Dest) > 0) or (Pos('..',Source) > 0) then Exit;

Below is the source code of TryCreateRelativePath, the line #318 is
now line #57:

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i 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;
I think the line #318 (or #57 in the copy-pasted code above) should be
removed. What do you think? Should I submit a bug report?

----------------------------------------------------------------------
cris75 · 2019-10-29 10:46

Hi all,
hi Handoko,
I have a function to produce a zip archive from a directory tree
storing only a relative path, it uses paszlib;
It is intended to be used in a Windows application and it's based on
the example in the paszlib wiki;
I noticed a couple of times a strange result in the zip archive
produced when
a file in the "directory tree to be zipped" does end with a dot
followed by a normal extension, in that case that specific file is
stored in the zip archive with the full path while the others are
(correctly) stored as expected;
after some search I deduced that the problem was in the
CreateRelativePath function in LazFileUtils;
so I found this thread while I was searching for documentation for the
above function and saw your post;
to me, the line you underlined seems actually to be the problem, if I
comment it out it and recompile LazFileUtils the zip result seems to
be ok;
I'm (still) on Lazarus 1.8.4 FPC 3.0.4 X86_64 LCL win32


Edit:
of course, the function is TryCreateRelativePath 

In my case the problem arise because there are two consecutive dots
(as explained);

Example code:

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i function
ZipWRelPath(const aZFileName: string; aRelativeDirectory: string;  out
anError: string): boolean;var  AZipper: TZipper;  ZEntries :
TZipFileEntries;  szPathEntry: string;  i:Integer;  fList:
TStringList;begin  Result:= False;  anError:= 'No errors.';  AZipper:=
TZipper.Create;  try    try      AZipper.Filename:= aZFileName;     
AZipper.Clear;      ZEntries:=
TZipFileEntries.Create(TZipFileEntry);       if
DirPathExists(aRelativeDirectory) then begin        i:=
RPos(PathDelim, ChompPathDelim(aRelativeDirectory));       
szPathEntry:= LeftStr(aRelativeDirectory, i);         fList:=
TstringList.Create;        try          FindAllFiles(fList,
aRelativeDirectory, '*.*');          for i:= 0 to fList.Count -1 do  
      begin            ZEntries.AddFileEntry(fList[i],
CreateRelativePath(fList[i],              szPathEntry));         
end;        finally          fList.Free;        end;      end;      if
(ZEntries.Count > 0) then        AZipper.ZipFiles(ZEntries);     
except        On E: EZipError do begin          anError:= 'Zipfile
could not be created, reason: ' + E.Message;        end;      end;   
Result:= True;  finally    FreeAndNil(ZEntries);    AZipper.Free; 
end;end;

----------------------------------------------------------------------
ccrause · 2020-01-19 09:38

Quote from: Handoko on October 01, 2019, 05:12:15 amSorry for posting
on an old thread.

I can reproduce the issue on Lazarus 2.0.4 FPC 3.0.4 GTK2 Linux
64-bit. Inspecting the source of lazfileutils.inc (function
TryCreateRelativePath), I found that line #318 is the cause of the
issue:
  if (Pos('..',Dest) > 0) or (Pos('..',Source) > 0) then Exit;
8<
I think the line #318 (or #57 in the copy-pasted code above) should be
removed. What do you think? Should I submit a bug report?

The original problem seems real, so it qualifies as a bug I think. 
The double dots check is probably used to detect a relative path in
the original paths, but a further check for three dots should be made
because that is a valid path or name sequence in Windows (or at least
.net).