В сишной функции realpath нашли уязвимость, и по сложившейся традиции, растрындели о ней в интернете
поскольку патчи безопасности завозят не везде, а поиск реального пути сложная задача, в которой могут всплыть и другие проблемы, пришлось взяться за альтернативный вариант - лазарусную функцию ReadAllLinks. Может раньше в линуксе она и хорошо работала, но теперь показаывает то полный путь, то локальный, с './' или без него. Выдрал из лазарусных исходников код, подправил и подсушил чтобы меньше весило.
Код: Выделить всё
{$GOTO ON}
{$MODE OBJFPC}
{$R+}
UNIT filerealpath;
interface
function Readrealpath(Filename: ansistring; ExceptionOnError: boolean;
var EFOpenError_: ansistring; dirprog: ansistring): ansistring;
//Filename - имя файла вместе с локальным или глобальным путём
//ExceptionOnError - true если надо проверять на ошибки и false если не надо
//EFOpenError_ - возвращает '' если ошибок не обнаружено или строку с текстом, если обнаружено
//dirprog - текущий каталог. Вычислять его при прыжках по каталогам 10000 раз в минуту, криво.
implementation
uses
baseunix,SysUtils;
var
PathDelim_: char='/';
function NacaloPuti(const Filename: ansistring):boolean;
begin
Result:=false;
if length(Filename)>0 then if Filename[1]=PathDelim_ then Result:=true;
{$ifdef windows}
Result:=false;
if ExtractFileDrive(Filename)<>'' then Result:=true; //реализация не протестирована
{$endif windows}
end;
function ResolveDots(const AFilename: ansistring): ansistring;
//trim double path delims and expand special dirs like .. and .
//on Windows change also '/' to '\' except for filenames starting with '\\?\'
var SrcPos, DestPos, l, DirStart: LongInt;
c: char;
MacroPos: LongInt;
begin
Result:=AFilename;
{$ifdef windows}
//Special case: everything is literal after this, even dots (this does not apply to '//?/')
if (Pos('\\?\', AFilename) = 1) then Exit;
{$endif}
l:=length(AFilename);
SrcPos:=1;
DestPos:=1;
// trim double path delimiters and special dirs . and ..
while (SrcPos<=l) do begin
c:=AFilename[SrcPos];
{$ifdef windows}
//change / to \. The WinApi accepts both, but it leads to strange effects in other places
if (c in AllowDirectorySeparators) then c := PathDelim;
{$endif}
// check for double path delims
if (c=PathDelim_) then begin
inc(SrcPos);
{$IFDEF Windows}
if (DestPos>2)
{$ELSE}
if (DestPos>1)
{$ENDIF}
and (Result[DestPos-1]=PathDelim_) then begin
// skip second PathDelim
continue;
end;
Result[DestPos]:=c;
inc(DestPos);
continue;
end;
// check for special dirs . and ..
if (c='.') then begin
if (SrcPos<l) then begin
if (AFilename[SrcPos+1]=PathDelim_)
and ((DestPos=1) or (AFilename[SrcPos-1]=PathDelim_)) then begin
// special dir ./
// -> skip
inc(SrcPos,2);
continue;
end else if (AFilename[SrcPos+1]='.')
and (SrcPos+1=l) or (AFilename[SrcPos+2]=PathDelim_) then
begin
// special dir ..
// 1. .. -> copy
// 2. /.. -> skip .., keep /
// 3. C:.. -> copy
// 4. C:\.. -> skip .., keep C:\
// 5. \\.. -> skip .., keep \\
// 6. xxx../.. -> copy
// 7. xxxdir/.. -> trim dir and skip ..
// 8. xxxdir/.. -> trim dir and skip ..
if DestPos=1 then begin
// 1. .. -> copy
end else if (DestPos=2) and (Result[1]=PathDelim_) then begin
// 2. /.. -> skip .., keep /
inc(SrcPos,2);
continue;
{$IFDEF Windows}
end else if (DestPos=3) and (Result[2]=':')
and (Result[1] in ['a'..'z','A'..'Z']) then begin
// 3. C:.. -> copy
end else if (DestPos=4) and (Result[2]=':') and (Result[3]=PathDelim_)
and (Result[1] in ['a'..'z','A'..'Z']) then begin
// 4. C:\.. -> skip .., keep C:\
inc(SrcPos,2);
continue;
end else if (DestPos=3) and (Result[1]=PathDelim_)
and (Result[2]=PathDelim_) then begin
// 5. \\.. -> skip .., keep \\
inc(SrcPos,2);
continue;
{$ENDIF}
end else if (DestPos>1) and (Result[DestPos-1]=PathDelim_) then begin
if (DestPos>3)
and (Result[DestPos-2]='.') and (Result[DestPos-3]='.')
and ((DestPos=4) or (Result[DestPos-4]=PathDelim_)) then begin
// 6. ../.. -> copy
end else begin
// 7. xxxdir/.. -> trim dir and skip ..
DirStart:=DestPos-2;
while (DirStart>1) and (Result[DirStart-1]<>PathDelim_) do
dec(DirStart);
MacroPos:=DirStart;
while MacroPos<DestPos do begin
if (Result[MacroPos]='$')
and (Result[MacroPos+1] in ['(','a'..'z','A'..'Z']) then begin
// 8. directory contains a macro -> keep
break;
end;
inc(MacroPos);
end;
if MacroPos=DestPos then begin
DestPos:=DirStart;
inc(SrcPos,2);
continue;
end;
end;
end;
end;
end else begin
// special dir . at end of filename
if DestPos=1 then begin
Result:='.';
exit;
end else begin
// skip
break;
end;
end;
end;
// copy directory
repeat
Result[DestPos]:=c;
inc(DestPos);
inc(SrcPos);
if (SrcPos>l) then break;
c:=AFilename[SrcPos];
{$ifdef windows}
//change / to \. The WinApi accepts both, but it leads to strange effects in other places
if (c in AllowDirectorySeparators) then c := PathDelim_;
{$endif}
if c=PathDelim_ then break;
until false;
end;
// trim result
if DestPos<=length(AFilename) then
SetLength(Result,DestPos-1);
end;
function ReadAllLinks_(const Filename: ansistring;
ExceptionOnError: boolean;var EFOpenError_: ansistring): ansistring;
var
LinkFilename: ansistring;
AText: ansistring;
Depth: longint;
label
100;
begin
Result:=Filename;
EFOpenError_:='';
Depth:=0;
while Depth<12 do begin
inc(Depth);
LinkFilename:=FpReadLink(Result);
if LinkFilename='' then begin
AText:='"'+Filename+'"';
case fpGetErrno() of
ESysEAcces:
AText:='read access denied for '+AText;
ESysENoEnt:
AText:='a directory component in '+AText
+' does not exist or is a dangling symlink';
ESysENotDir:
AText:='a directory component in '+AText+' is not a directory';
ESysENoMem:
AText:='insufficient memory';
ESysELoop:
AText:=AText+' has a circular symbolic link';
else
// not a symbolic link, just a regular file
goto 100;// exit;
end;
if (not ExceptionOnError) then begin
Result:='';
goto 100; //exit;
end;
//raise EFOpenError.Create(AText); //отключено, т.к. сейчас не надо, а зависимости тяжёлые
EFOpenError_:=EFOpenError_+AText; //замена
end else begin
if not NacaloPuti(LinkFilename) then
Result:=ResolveDots(ExtractFilePath(Result)+LinkFilename)
else
Result:=LinkFilename;
end;
end;
// probably an endless loop
if ExceptionOnError then
//raise EFOpenError.Create('too many links, maybe an endless loop.') //отключено, т.к. сейчас не надо, а зависимости тяжёлые
EFOpenError_:=EFOpenError_+' too many links, maybe an endless loop.' //замена
else
Result:='';
100:
if EFOpenError_<>'' then begin
// writeln('function ReadAllLinks ERROR: ',EFOpenError_);
//обработчик ошибки
end;
end;
function Readrealpath(Filename: ansistring; ExceptionOnError: boolean;
var EFOpenError_: ansistring; dirprog: ansistring): ansistring;
var
XX5,ZZ5:ansistring;
begin
XX5:=ExtractFilePath(Filename);
if XX5<>''then Chdir(XX5);
GetDir(0,ZZ5);
Chdir(dirprog);
Filename:=ZZ5+PathDelim_+ExtractFileName(Filename);
Readrealpath:=ReadAllLinks_(Filename,ExceptionOnError,EFOpenError_);
end;
begin
{$ifdef windows}
PathDelim_: char='\';
{$endif windows}
{$ifdef dos}
PathDelim_: char='\';
{$endif dos}
end.
Вроде работает хорошо, но есть два вопроса:
1.Есть ли способ просканировать путь из каталога файла без изменения текущего каталога - "Chdir(XX5); GetDir(0,ZZ5);"?
2.Если прикладывать этот исходник вместе с программами, то нужно ему в шапку какую-то лицензию вписать. А какая лицензия у функций ResolveDots и ReadAllLinks сейчас? Функции реализованы в инклудах файла lazfileutils.pas в котором никаких лицензий в шапке не указано. Не хотелось чтобы там вдруг когда-то нарисовалась добрая лицензия GPL 2+ - она же не даст делать программам никакие другие лицензии и т.д.
После того как пересобрал на своём линуксе (федора 17) fpc-3.0.4 (этот научился линковщику и глибцу старых версий) и lazarus 1.8.0, лазарус стал запускаться и даже компилять рабочие бинарники, но подсказки по ctrl и ctrl+alt работают хреново и буквы в этом окне чудят. Наверно эта версия лазаруса не предназначена для старых глибца и линковщика. Собрать то бинари она для них может. В принципе лазаруса 1.6.4 ещё на долго хватит.