abutils.pas

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

  end;

  DTABuf = array[0..63] of AnsiChar;

  PMediaIDType = ^MediaIDType;
  MediaIDType = packed record
  {This type describes the information that DOS 4.0 or higher writes
   in the boot sector of a disk when it is formatted}
    InfoLevel : Word;                        {Reserved for future use}
    SerialNumber : LongInt;                  {Disk serial number}
    VolumeLabel : array[0..10] of AnsiChar;  {Disk volume label}
    FileSystemID : array[0..7] of AnsiChar;  {String for internal use by the OS}
  end;

{===platform independent routines for platform dependent stuff=======}
function ExtractShortName(const SR : TSearchRec) : string;
begin
  {$IFDEF MSWINDOWS}
  {$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
  if SR.FindData.cAlternateFileName[0] <> #0 then
    Result := SR.FindData.cAlternateFileName
  else
    Result := SR.FindData.cFileName;
  {$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
  {$ENDIF}
  {$IFDEF LINUX}
  Result := SR.Name;
  {$ENDIF}
end;
{====================================================================}


{ TAbPadLock implementation ================================================ }
constructor TAbPadLock.Create;
begin
  inherited Create;
//!!MVC  InitializeCriticalSection(plCritSect);
end;
{ -------------------------------------------------------------------------- }
destructor TAbPadLock.Destroy;
begin
//!!MVC  DeleteCriticalSection(plCritSect);
  inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
function TAbPadLock.GetLocked : boolean;
begin
  Result := FCount > 0;
end;
{ -------------------------------------------------------------------------- }
procedure TAbPadLock.SetLocked(L : boolean);
begin
  if L {locking} then begin
    if IsMultiThread then begin
//!!MVC      EnterCriticalSection(plCritSect);
      inc(FCount);
    end;
  end
  else {unlocking} begin
    if (FCount > 0) then begin
      dec(FCount);
//!!MVC      LeaveCriticalSection(plCritSect);
    end;
  end;
end;
{ ========================================================================== }


{ ========================================================================== }
procedure AbCreateDirectory( const Path : string );
  {creates the requested directory tree.  CreateDir is insufficient,
   because if you have a path x:\dir, and request x:\dir\sub1\sub2,
   (/dir and /dir/sub1/sub2 on Linux) it fails.}
var
  iStartSlash : Integer;
  i : Integer;
  TempPath : string;
begin
  if AbDirectoryExists( Path ) then
    Exit;
  {see how much of the path currently exists}
  if Pos( '\\', Path ) > 0 then
    {UNC Path  \\computername\sharename\path1..\pathn}
    iStartSlash := 5
  else
    {standard Path drive:\path1..\pathn}
    iStartSlash := 2;

  repeat
    {find the Slash at iStartSlash}
    i := AbFindNthSlash( Path, iStartSlash );
    {get a temp path to try: drive:\path1}
    TempPath := Copy( Path, 1, i );
    {if it doesn't exist, create it}
    if not AbDirectoryExists( TempPath ) then
      MkDir( TempPath );
    inc( iStartSlash );
  until ( Length( TempPath ) = Length( Path ) );
end;
{ -------------------------------------------------------------------------- }
function AbCreateTempFile(Dir : string) : string;
begin
  Result := AbGetTempFile(Dir, True);
end;
{ -------------------------------------------------------------------------- }
{$IFDEF LINUX}
function GetTempFileName(const Path, Mask : string): string;
{
Returns a unique filename for use as a temporary
}
var
  Buff: array[0..AB_MAXPATH] of char;
  IntMask : string;
begin
  IntMask := Mask;
  if Copy(IntMask, Length(IntMask) - 5, 6) <> 'XXXXXX' then
    IntMask := IntMask + 'XXXXXX';
  StrPCopy(Buff, AbAddBackSlash(Path) + IntMask);
  mktemp(Buff);
  Result := StrPas(Buff);
end;
{$ENDIF}

function AbGetTempFile(Dir : string; CreateIt : Boolean) : string;
{$IFDEF MSWINDOWS}
var
  FileNameZ : array [0..259] of char;
  TempPathZ : array [0..259] of char;
{$ENDIF}
begin
{$IFDEF MSWINDOWS}
  if not AbDirectoryExists(Dir) then
    GetTempPath(sizeof(TempPathZ), TempPathZ)
  else
    StrPCopy(TempPathZ, Dir);
  GetTempFileName(TempPathZ, 'VMS', Word(not CreateIt), FileNameZ);
  Result := StrPas(FileNameZ);
{$ENDIF}
{$IFDEF LINUX}
  Result := GetTempFileName(Dir, 'VMSXXXXXX');
  if CreateIt then
    FileCreate(Result);
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
function AbdMax(Var1, Var2: Longint): Longint;
  {-Return the maximum of two values}
begin
  if (Var2 > Var1) then
    Result := Var2
  else
    Result := Var1;
end;
{ -------------------------------------------------------------------------- }
function AbdMin(Var1, Var2: DWord): DWord;
  {-Return the minimum of two values}
begin
  if (Var2 < Var1) then
    Result := Var2
  else
    Result := Var1;
end;
{ -------------------------------------------------------------------------- }
function AbDrive(const ArchiveName : string) : AnsiChar;
var
  iPos: Integer;
  Path : string;
begin
  Path := ExpandFileName(ArchiveName);
  iPos := Pos(':', Path);
  if (iPos <= 0) then
    Result := 'A'
  else
    Result := Path[1];
end;
{ -------------------------------------------------------------------------- }
function AbDriveIsRemovable(const ArchiveName : string) : Boolean;       
var
{$IFDEF MSWINDOWS}
  DType : Integer;
  iPos  : Integer;
  Drive : array[0..4] of Char;
{$ENDIF}
  Path : string;
{$IFDEF LINUX}
  Path2: string;
{$ENDIF}
begin
  Path := ExpandFileName(ArchiveName);
{$IFDEF MSWINDOWS}
  Result := False;
  iPos := Pos(':', Path);
  if (iPos <= 0) then
    Exit;
  System.Delete(Path, iPos+1, Length(Path) - iPos);
  StrPLCopy(Drive, Path, Length(Path));
  DType := GetDriveType(Drive);
  Result := (DType = DRIVE_REMOVABLE);
{$ENDIF}
{$IFDEF LINUX}
  Path2 := LowerCase(ExtractFilePath(Path));
  {LINUX -- Following may not cover all the bases}
  Result := Path2 = '/mnt/floppy';
{$ENDIF}

end;
{ -------------------------------------------------------------------------- }
{!!.01 -- Rewritten}
function AbGetDriveFreeSpace(const ArchiveName : string) : LongInt;
{ attempt to find free space (in bytes) on drive/volume,
  returns MaxLongInt on drives with greater space,
  returns -1 if fails for some reason }

{$IFDEF MSWINDOWS }
function GetLocalDiskFree(const Path : string) : {$IFDEF VERSION4} Int64 {$ELSE} LongInt {$ENDIF};
var
  SectorsPerCluster, BytesPerSector,
  NumberOfFreeClusters, TotalNumberOfClusters : {$IFDEF VERSION4} Cardinal {$ELSE} LongInt {$ENDIF};
  Succeeded : BOOL;
  DrvBuf : array[0..255] of char;
begin
  Result := -1;
  StrPCopy(DrvBuf, ExtractFileDrive(Path) + AbDosPathDelim);
  Succeeded := GetDiskFreeSpace(DrvBuf,
    SectorsPerCluster, BytesPerSector, NumberOfFreeClusters, TotalNumberOfClusters);
  if Succeeded then
{!!.03 -- Rewritten}
    try
      Result := BytesPerSector * SectorsPerCluster * NumberOfFreeClusters;
    except
      on EIntOverflow do
        Result := High(Result);
    end;
{!!.03 -- End Rewritten}
end;

function GetRemoteDiskFree(const Path : string) : {$IFDEF VERSION4} Int64 {$ELSE} LongInt {$ENDIF};
var
  FreeAvailable, TotalSpace, TotalFree: {$IFDEF VERSION4} TLargeInteger {$ELSE} LongInt {$ENDIF};
  Succeeded : BOOL;
  PathBuf : array[0..255] of char;
begin
  Result := -1;
  StrPCopy(PathBuf, AbAddBackSlash(ExtractFilePath(Path)));
  Succeeded := GetDiskFreeSpaceEx(PathBuf, FreeAvailable, TotalSpace, @TotalFree);
  if Succeeded then
    Result := FreeAvailable;
end;

function GetRemoveableDiskFree(const Path : string) : LongInt;
begin
  Result := DiskFree(Ord(AbDrive(Path)) - Ord('A') + 1);
end;

function OSOK : boolean;
var
  VerInfo : TOSVersionInfo;
begin
  Result := False;
  {get the version info}
  VerInfo.dwOSVersionInfoSize := sizeof(VerInfo);
  if GetVersionEx(VerInfo) then
    { if is NT or Win9x > 95a }
    Result :=
      ((VerInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) and
       (VerInfo.dwMajorVersion >= 4))
      or
      ((VerInfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS) and
       (LongRec(VerInfo.dwBuildNumber).Lo <> 1000));
end;
{$ENDIF MSWINDOWS}
{$IFDEF LINUX}
function LinuxVolumeFree(const Path : string): Int64;
var
  FStats : TStatFs;
  Rslt : Integer;
begin
  Result := -1;
  Rslt := statfs(PAnsiChar(ExtractFilePath(Path)), FStats);
  if Rslt = 0 then
    Result := Int64(FStats.f_bAvail) * Int64(FStats.f_bsize);
end;

function LinuxVolumeSize(const Path : string): Int64;
var
  FStats : TStatFs;
  Rslt : Integer;
begin
  Result := -1;
  Rslt := statfs(PAnsiChar(ExtractFilePath(Path)), FStats);
  if Rslt = 0 then
    Result := Int64(FStats.f_blocks) * Int64(FStats.f_bsize);
end;
{$ENDIF LINUX}

var
{$IFDEF MSWINDOWS}
{$IFDEF VERSION4}
  Size : Int64;
{$ELSE}
  Size : Integer;
{$ENDIF VERSION4}
  DrvTyp : Integer;
  DrvStr : string;                                                       {!!.02}
{$ENDIF MSWINDOWS}
{$IFDEF LINUX}
  Size : Int64;
{$ENDIF}
begin
{$IFDEF MSWINDOWS }
  Size := -1;

  DrvStr := ExtractFileDrive(ArchiveName);                               {!!.02}
  if DrvStr = '' then                                                    {!!.02}
    DrvStr := ExtractFileDrive(GetCurrentDir);                           {!!.02}
  DrvStr := DrvStr + AbDosPathDelim;                                     {!!.02}

  case AbGetPathType(ArchiveName) of
    ptNone, ptRelative: { if path is relative or bad }
      Size := -1; { fail }
    ptAbsolute : begin {path is absolute}
      if Pos('\\', ArchiveName) = 1 then begin  {path is UNC; must refer to network }
        { check OS version }
        if OSOK then begin
          Size := GetRemoteDiskFree(DrvStr);                             {!!.02}
        end
        else begin {OS < Win95b }
          {GetDiskFreeSpaceEx isn't available and
           GetDiskFreeSpace and DiskFree fail on UNC paths,
           about all we can do is hope the server isn't full}
            Size := MaxLongInt;
        end; {if}
      end
      else begin { path is not UNC}
        { determine drive type }
        DrvTyp := GetDriveType(PAnsiChar(DrvStr));                       {!!.02}
        {DrvTyp := GetDriveType(PAnsiChar(ExtractFilePath(ArchiveName))); }{!!.02}
        case DrvTyp of
          0 {type undeterminable} : Size := -1; { fail }
          1 {root non-existant}   : Size := -1; { fail }
          DRIVE_RAMDISK           : Size := -1; { fail }

//        DRIVE_CDROM           : Size := -1; { fail }                 {!!.04}
//        DRIVE_CDROM           : Size := 0; { Read-Only }             {!!.04}
          DRIVE_CDROM             : Size := GetLocalDiskFree(DrvStr);  {!!.04}
          DRIVE_REMOVABLE         : Size := GetRemoveableDiskFree(DrvStr); {!!.02}
          DRIVE_FIXED             : Size := GetLocalDiskFree(DrvStr);      {!!.02}
          DRIVE_REMOTE            : Size := GetRemoteDiskFree(DrvStr);     {!!.02}
        end; {case}
      end; {if}
    end; {ptAbsolute}
  end; {case AbGetPathType}
{$ENDIF MSWINDOWS}
{$IFDEF LINUX}
  Size := LinuxVolumeFree(ArchiveName);
{$ENDIF LINUX}
  if (Size < -1) or (Size > MaxLongInt) then begin
    Result := MaxLongInt;
  end
  else begin
    Result := Size;
  end;
end;
{ -------------------------------------------------------------------------- }
{!!.01 -- End Rewritten}

{ -------------------------------------------------------------------------- }
function AbDirectoryExists( const Path : string ) : Boolean;
{$IFDEF MSWINDOWS}
var
  Attr : DWORD;
  PathZ: array [0..255] of AnsiChar;