mirror of
				https://gitlab.com/freepascal.org/fpc/source.git
				synced 2025-11-04 07:43:04 +01:00 
			
		
		
		
	+ Added missing functions and some extra
This commit is contained in:
		
							parent
							
								
									3e9facf089
								
							
						
					
					
						commit
						2de00518e3
					
				@ -83,9 +83,108 @@ if (I > 0) and (FileName[I] = '.') then
 | 
			
		||||
else Result := '';
 | 
			
		||||
end;
 | 
			
		||||
 | 
			
		||||
function ExpandFileName (Const FileName : string): String;
 | 
			
		||||
 | 
			
		||||
Begin
 | 
			
		||||
{$ifdef linux}
 | 
			
		||||
  Result:=Linux.fexpand(FileName);
 | 
			
		||||
{$else}
 | 
			
		||||
  Result:=Dos.Fexpand(FileName);
 | 
			
		||||
{$endif}
 | 
			
		||||
end;
 | 
			
		||||
 | 
			
		||||
function ExpandUNCFileName (Const FileName : string): String;
 | 
			
		||||
begin
 | 
			
		||||
  Result:=ExpandFileName (FileName);
 | 
			
		||||
  //!! Here should follow code to replace the drive: part with UNC...
 | 
			
		||||
end;
 | 
			
		||||
 | 
			
		||||
Const MaxDirs = 129;
 | 
			
		||||
 | 
			
		||||
function ExtractRelativepath (Const BaseName,DestName : String): String;
 | 
			
		||||
 | 
			
		||||
Var Source, Dest : String;
 | 
			
		||||
    Sc,Dc,I,J    : Longint;
 | 
			
		||||
    SD,DD        : Array[1..MaxDirs] of PChar;
 | 
			
		||||
 | 
			
		||||
Const OneLevelBack = '..'+OSDirSeparator;
 | 
			
		||||
 | 
			
		||||
begin
 | 
			
		||||
  If Upcase(ExtractFileDrive(BaseName))<>Upcase(ExtractFileDrive(DestName)) Then
 | 
			
		||||
    begin
 | 
			
		||||
    Result:=DestName;
 | 
			
		||||
    exit;
 | 
			
		||||
    end;
 | 
			
		||||
  Source:=ExtractFilePath(BaseName);
 | 
			
		||||
  Dest:=ExtractFilePath(DestName);
 | 
			
		||||
  SC:=GetDirs (Source,SD);
 | 
			
		||||
  DC:=GetDirs (Dest,DD);
 | 
			
		||||
  I:=1;
 | 
			
		||||
  While (I<DC) and (I<SC) do
 | 
			
		||||
    begin
 | 
			
		||||
    If StrIcomp(DD[i],SD[i])=0 then 
 | 
			
		||||
      Inc(i)
 | 
			
		||||
    else
 | 
			
		||||
      Break;
 | 
			
		||||
    end;
 | 
			
		||||
  Result:='';
 | 
			
		||||
  For J:=I to SC-1 do Result:=Result+OneLevelBack;
 | 
			
		||||
  For J:=I to DC-1 do Result:=Result+DD[J]+OsDirSeparator;
 | 
			
		||||
  Result:=Result+ExtractFileName(DestNAme);
 | 
			
		||||
end;
 | 
			
		||||
 | 
			
		||||
Procedure DoDirSeparators (Var FileName : String);
 | 
			
		||||
 | 
			
		||||
VAr I : longint;
 | 
			
		||||
 | 
			
		||||
begin
 | 
			
		||||
  For I:=1 to Length(FileName) do
 | 
			
		||||
    If FileName[I] in DirSeparators then 
 | 
			
		||||
      FileName[i]:=OSDirSeparator;
 | 
			
		||||
end;
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
Function SetDirSeparators (Const FileName : string) : String;
 | 
			
		||||
 | 
			
		||||
begin
 | 
			
		||||
  Result:=FileName;
 | 
			
		||||
  DoDirSeparators (Result);
 | 
			
		||||
end;
 | 
			
		||||
 | 
			
		||||
{
 | 
			
		||||
  DirName is split in a #0 separated list of directory names,
 | 
			
		||||
  Dirs is an array of pchars, pointing to these directory names.
 | 
			
		||||
  The function returns the number of directories found, or -1
 | 
			
		||||
  if none were found.
 | 
			
		||||
  DirName must contain only OSDirSeparator as Directory separator chars.
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
Function GetDirs (Var DirName : String; Var Dirs : Array of pchar) : Longint; 
 | 
			
		||||
 | 
			
		||||
Var I : Longint;
 | 
			
		||||
 | 
			
		||||
begin
 | 
			
		||||
  I:=1; 
 | 
			
		||||
  Result:=-1;
 | 
			
		||||
  While I<=Length(DirName) do
 | 
			
		||||
    begin
 | 
			
		||||
    If DirName[i]=OsDirSeparator then
 | 
			
		||||
      begin
 | 
			
		||||
      DirName[i]:=#0;
 | 
			
		||||
      Inc(Result);
 | 
			
		||||
      Dirs[Result]:=@DirName[I+1];
 | 
			
		||||
      end;
 | 
			
		||||
    Inc(I);
 | 
			
		||||
    end;
 | 
			
		||||
  If Result>-1 then inc(Result);
 | 
			
		||||
end;
 | 
			
		||||
 | 
			
		||||
{
 | 
			
		||||
  $Log$
 | 
			
		||||
  Revision 1.2  1998-09-16 08:28:38  michael
 | 
			
		||||
  Revision 1.3  1998-10-04 20:19:56  michael
 | 
			
		||||
  + Added missing functions and some extra
 | 
			
		||||
 | 
			
		||||
  Revision 1.2  1998/09/16 08:28:38  michael
 | 
			
		||||
  Update from gertjan Schouten, plus small fix for linux
 | 
			
		||||
 | 
			
		||||
  Revision 1.1  1998/04/10 15:17:46  michael
 | 
			
		||||
 | 
			
		||||
@ -21,15 +21,33 @@
 | 
			
		||||
    System Utilities For Free Pascal
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
Const
 | 
			
		||||
  DirSeparators : set of char = ['/','\'];  
 | 
			
		||||
{$ifdef Linux}
 | 
			
		||||
  OSDirSeparator = '/';
 | 
			
		||||
{$else}
 | 
			
		||||
  OsDirSeparator = '\';
 | 
			
		||||
{$endif}
 | 
			
		||||
 | 
			
		||||
function ChangeFileExt(const FileName, Extension: string): string;
 | 
			
		||||
function ExtractFilePath(const FileName: string): string;
 | 
			
		||||
function ExtractFileDrive(const FileName: string): string;
 | 
			
		||||
function ExtractFileName(const FileName: string): string;
 | 
			
		||||
function ExtractFileExt(const FileName: string): string; { Returns file extension like '.123' }
 | 
			
		||||
function ExtractFileExt(const FileName: string): string; 
 | 
			
		||||
function ExtractFileDir(Const FileName : string): string;
 | 
			
		||||
function ExpandFileName (Const FileName : string): String;
 | 
			
		||||
function ExpandUNCFileName (Const FileName : string): String;
 | 
			
		||||
function ExtractRelativepath (Const BaseName,DestNAme : String): String;
 | 
			
		||||
Procedure DoDirSeparators (Var FileName : String);
 | 
			
		||||
Function SetDirSeparators (Const FileName : String) : String;
 | 
			
		||||
Function GetDirs (Var DirName : String; Var Dirs : Array of pchar) : Longint; 
 | 
			
		||||
 | 
			
		||||
{
 | 
			
		||||
  $Log$
 | 
			
		||||
  Revision 1.2  1998-09-16 08:28:39  michael
 | 
			
		||||
  Revision 1.3  1998-10-04 20:19:55  michael
 | 
			
		||||
  + Added missing functions and some extra
 | 
			
		||||
 | 
			
		||||
  Revision 1.2  1998/09/16 08:28:39  michael
 | 
			
		||||
  Update from gertjan Schouten, plus small fix for linux
 | 
			
		||||
 | 
			
		||||
  Revision 1.1  1998/04/10 15:17:46  michael
 | 
			
		||||
 | 
			
		||||
		Loading…
	
		Reference in New Issue
	
	Block a user