abutils.pas

Lazarus is a free and open source development tool for the FreePascal Compiler. The purpose of the p

{$ENDIF}
{$IFDEF LINUX}
var
  SB: TStatBuf;
{$ENDIF}

begin
  Result := False;
  {we don't support wildcards}
  if (Pos('*', Path) <> 0) or (Pos('?', Path) <> 0) then
    Exit;
{$IFDEF MSWINDOWS}
  Attr := GetFileAttributes( StrPCopy( PathZ, Path ) );
  if (Attr <> DWORD(-1)) and ((Attr and faDirectory) <> 0) then
    Result := true;
{$ENDIF}
{$IFDEF LINUX}
  if FileExists(Path) then begin
    stat(PAnsiChar(Path), SB);
      
    Result := (SB.st_mode and AB_FMODE_DIR) = AB_FMODE_DIR;
  end;
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
function AbFileMatch(FileName: string; FileMask: string ): Boolean;
  {see if FileName matches FileMask}
var
  DirMatch : Boolean;
  MaskDir : string;
begin
  FileName := UpperCase( FileName );
  FileMask := UpperCase( FileMask );
  MaskDir := ExtractFilePath( FileMask );
  if MaskDir = '' then
    DirMatch := True
  else
    DirMatch := AbPatternMatch( ExtractFilePath( FileName ), 1, MaskDir, 1 );

  Result := DirMatch and AbPatternMatch( ExtractFileName( FileName ), 1,
                                       ExtractFileName( FileMask ), 1 );
end;
{ -------------------------------------------------------------------------- }
procedure AbFindFiles( const FileMask : string; SearchAttr : Integer;
                       FileList : TStrings; Recurse : Boolean );
var
  NewFile : string;
  SR : TSearchRec;
  Found : Integer;
  NameMask: string;
begin
  Found := FindFirst( FileMask, SearchAttr, SR );
  if Found = 0 then begin
    try
      NameMask := UpperCase(ExtractFileName(FileMask));
      while Found = 0 do begin
        NewFile := ExtractFilePath( FileMask ) + SR.Name;
        if AbPatternMatch(UpperCase(SR.Name), 1, NameMask, 1) then
        FileList.Add( NewFile );
        Found := FindNext( SR );
      end;
    finally
      FindClose( SR );
    end;
  end;
  if not Recurse then
    Exit;
  NewFile := ExtractFilePath( FileMask );
  if ( NewFile <> '' ) and ( NewFile[Length(NewFile)] <> AbPathDelim) then
    NewFile := NewFile + AbPathDelim;
  NewFile := NewFile + AbAnyFile;

  Found := FindFirst( NewFile, faDirectory, SR );
  if Found = 0 then begin
    try
      while ( Found = 0 ) do begin
        if ( SR.Name <> AbThisDir ) and
           ( SR.Name <> AbParentDir ) and
           ((SR.Attr and faDirectory) > 0 ) then
          AbFindFiles( ExtractFilePath( NewFile ) + SR.Name + AbPathDelim +
                       ExtractFileName( FileMask ), SearchAttr,          {!!.04}
                       FileList, True );
        Found := FindNext( SR );
      end;
    finally
      FindClose( SR );
    end;
  end;
end;
{ -------------------------------------------------------------------------- }
procedure AbFindFilesEx( const FileMask : string; SearchAttr : Integer;
                       FileList : TStrings; Recurse : Boolean );
var
  I, J: Integer;
  MaskPart: string;
begin
  I := 1;
  while I <= Length(FileMask) do begin
    J := I;
    while (I <= Length(FileMask)) and (FileMask[I] <> AbPathSep) do Inc(I);
    MaskPart := Trim(Copy(FileMask, J, I - J));
    if (I <= Length(FileMask)) and (FileMask[I] = AbPathSep) then Inc(I);

    AbFindFiles(MaskPart, SearchAttr, FileList, Recurse);
  end;
end;
{ -------------------------------------------------------------------------- }
function AbAddBackSlash(const DirName : string) : string;
{ Add a default slash to a directory name }
const
  AbDelimSet : set of Char = [AbPathDelim, ':', #0];
begin
  Result := DirName;
  if Length(DirName) = 0 then
    Exit;
  if not (DirName[Length(DirName)] in AbDelimSet) then
    Result := DirName + AbPathDelim;
end;
{ -------------------------------------------------------------------------- }
function AbFindNthSlash( const Path : string; n : Integer ) : Integer;
{ return the position of the character just before the nth slash }
var
  i : Integer;
  Len : Integer;
  iSlash : Integer;
begin
  Len := Length( Path );
  Result := Len;
  iSlash := 0;
  i := 0;
  while i <= Len do begin
    if Path[i] = AbPathDelim then begin
      inc( iSlash );
      if iSlash = n then begin
        Result := pred( i );
        break;
      end;
    end;
    inc( i );
  end;
end;
{ -------------------------------------------------------------------------- }
function AbGetPathType( const Value : string ) : TAbPathType;
{ returns path type - none, relative or absolute }
begin
  Result := ptNone;
{$IFDEF MSWINDOWS}
{check for drive/unc info}
  if ( Pos( '\\', Value ) > 0 ) or ( Pos( ':', Value ) > 0 ) then
{$ENDIF MSWINDOWS}
{$IFDEF LINUX}
{ UNIX absolute paths start with a slash }
  if (Value[1] = AbPathDelim) then
{$ENDIF LINUX}
    Result := ptAbsolute
  else if ( Pos( AbPathDelim, Value ) > 0 ) or ( Pos( AB_ZIPPATHDELIM, Value ) > 0 ) then
    Result := ptRelative;
end;
{ -------------------------------------------------------------------------- }
{$IFDEF MSWINDOWS}
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
function AbGetShortFileSpec( LongFileSpec : string ) : string;
var
  SR : TSearchRec;
  Search : string;
  Drive : string;
  Path : string;
  FileName : string;
  Found : Integer;
  SubPaths : TStrings;
  i : Integer;
begin
  AbParseFileName( LongFileSpec, Drive, Path, FileName );
  SubPaths := TStringList.Create;
  try
    AbParsePath( Path, SubPaths );
    Search := Drive;
    Result := Search + AbPathDelim;
    if SubPaths.Count > 0 then
      for i := 0 to pred( SubPaths.Count ) do begin
        Search := Search + AbPathDelim + SubPaths[i];
        Found := FindFirst( Search, faHidden + faSysFile + faDirectory, SR );
        if Found <> 0 then
          raise EAbException.Create( 'Path not found' );
        try
          Result := Result + ExtractShortName(SR) + AbPathDelim;
        finally
          FindClose( SR );
        end;
      end;
    Search := Search + AbPathDelim + FileName;
    Found := FindFirst( Search,
                        faReadOnly + faHidden + faSysFile + faArchive, SR );
    if Found <> 0 then
      raise EAbFileNotFound.Create;
    try
      Result := Result + ExtractShortName(SR);
    finally
      FindClose( SR );
    end;
  finally
    SubPaths.Free;
  end;
end;
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
{$ENDIF}
{ -------------------------------------------------------------------------- }
procedure AbIncFilename( var Filename : string; Value : Word );
{ place value at the end of filename, e.g. Files.C04 }
var
  Ext : string[4];
  I : Word;
begin
  I := Value mod 100;
  Ext := ExtractFileExt(Filename);
  if (Length(Ext) < 2) then
    Ext := '.' + Format('%.2d', [I])
  else
    Ext := Ext[1] + Ext[2] + Format('%.2d', [I]);
  Filename := ChangeFileExt(Filename, Ext);
end;
{ -------------------------------------------------------------------------- }
procedure AbParseFileName( FileSpec : string;
                           var Drive : string;
                           var Path : string;
                           var FileName : string );
var
  i : Integer;
  iColon : Integer;
  iStartSlash : Integer;
begin
  if Pos( AB_ZIPPATHDELIM, FileSpec ) > 0 then
    AbUnfixName( FileSpec );
  FileName := ExtractFileName( FileSpec );
  Path := ExtractFilePath( FileSpec );
  {see how much of the path currently exists}
  iColon := Pos( ':', Path );
  if Pos( '\\', Path ) > 0 then begin
    {UNC Path  \\computername\sharename\path1..\pathn}
    {everything up to the 4th slash is the drive}
    iStartSlash := 4;
    i := AbFindNthSlash( Path, iStartSlash );
    Drive := Copy( Path, 1, i );
    Delete( Path, 1, i + 1 );
  end
  else if iColon > 0 then begin
    Drive := Copy( Path, 1, iColon );
    Delete( Path, 1, iColon );
    if Path[1] = AbPathDelim then
      Delete( Path, 1, 1 );
  end;
end;
{ -------------------------------------------------------------------------- }
procedure AbParsePath( Path : string; SubPaths : TStrings );
{ break abart path into subpaths --- Path : abbrevia/examples >
                                        SubPaths[0] = abbrevia
                                        SubPaths[1] = examples}
var
  i : Integer;
  iStart : Integer;
  iStartSlash : Integer;
  SubPath : string;
begin
  if Path = '' then Exit;
  if Path[ Length( Path ) ] = AbPathDelim then
    Delete( Path, Length( Path ), 1 );
  iStart := 1;
  iStartSlash := 1;
  repeat
    {find the Slash at iStartSlash}
    i := AbFindNthSlash( Path, iStartSlash );
    {get the subpath}
    SubPath := Copy( Path, iStart, i - iStart + 1 );
    iStart := i + 2;
    inc( iStartSlash );
    SubPaths.Add( SubPath );
  until ( i = Length( Path ) );
end;
{ -------------------------------------------------------------------------- }
function AbPatternMatch( Source : string; iSrc : Integer;
                Pattern : string; iPat : Integer ) : Boolean;
{ recursive routine to see if the source string matches
  the pattern.  Both ? and * wildcard characters are allowed.
  Compares Source from iSrc to Length(Source) to
  Pattern from iPat to Length(Pattern)}
var
  Matched : Boolean;
  k : Integer;
begin
  if Length( Source ) = 0 then begin
    Result := Length( Pattern ) = 0;
    Exit;
  end;

  if iPat = 1 then begin
    if ( CompareStr( Pattern, AbDosAnyFile) = 0 ) or
       ( CompareStr( Pattern, AbUnixAnyFile ) = 0 ) then begin
      Result := True;
      Exit;
    end;
  end;

  if Length( Pattern ) = 0 then begin
    Result := (Length( Source ) - iSrc + 1 = 0);
    Exit;
  end;

  while True do begin
    if ( Length( Source ) < iSrc ) and
       ( Length( Pattern ) < iPat ) then begin
      Result := True;
      Exit;
    end;

    if Length( Pattern ) < iPat then begin
      Result := False;
      Exit;
    end;

    if Pattern[iPat] = '*' then begin
      k := iPat;
      if ( Length( Pattern ) < iPat + 1 ) then begin
        Result := True;
        Exit;
      end;

      while True do begin
        Matched := AbPatternMatch( Source, k, Pattern, iPat + 1 );
        if Matched or ( Length( Source ) < k ) then begin
          Result := Matched;
          Exit;
        end;
        inc( k );
      end;
    end
    else begin
      if ( (Pattern[iPat] = '?') and
           ( Length( Source ) <> iSrc - 1 ) ) or
           ( Pattern[iPat] = Source[iSrc] ) then begin
        inc( iPat );
        inc( iSrc );
      end
      else begin
        Result := False;
        Exit;
      end;
    end;
  end;
end;
{ -------------------------------------------------------------------------- }
function AbPercentage(V1, V2 : LongInt) : Byte;
{ Returns the ratio of V1 to V2 * 100 }
begin
  if V2 > 16384000 then begin  {Possible LongInt overflow}
    V1 := (V1 + $80) shr 8;  {scale down (div 256)}
    V2 := (V2 + $80) shr 8;  {scale down (div 256)}
  end;
  if V2 <= 0 then
    Result := 0
  else if V1 >= V2 then
    Result := 100
  else
    Result := (V1 * 100) div V2;
end;
{ -------------------------------------------------------------------------- }
procedure AbStripDots( var FName : string );
{ strips relative path information, e.g. ".."}
begin
  while Pos( AbParentDir + AbPathDelim, FName ) = 1 do
    System.Delete( FName, 1, 3 );
end;
{ -------------------------------------------------------------------------- }