rsvk/Component/EDosUnit.pas

unit EDosUnit;
{-------------------------------------------------------------------------------
Supporting Dos Unit.
-------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg

  revision 2.1

 Delphi version: 4.0

 Purpose: Provide encapsulation and better error handling for delphi's
          file/system functions.

 Notes: This unit started out a long time ago to add to the Dos unit.
        Delphi adds alot of system functionality that makes many of these procedures
        redundant. Using this or Delphi's one should be similar.
        Many procedures have been commented out, deleted or lost because they
        were either too old or were lost in one of those h/d crash.

 Conventions :
   - S is used to represent "DirectoryString" or generally, string.


 Rules to follow :
   Directory paths:
   - All directories end with a '\'
     AddSlash appends the '\' if necessary.
     DelSlash removes the '\' if there is one

   File names/paths:
   - file names may contain no extension.


   - File seperators are '\'
   - All file names are in 'string' type.


   TDriveList
   ----------
   Used for enumerating drives


   DEFUNCT: TEnSearchRec
   ---------------------
   The TEnhSearchRec (Enhanced Search Record) is a customized search
   record object.
   notes:
   The fileTime used here is an integer. See FileDateToDateTime.

   methods :
   - constructor CreateFrom(const f: TSearchRec);
     Creates a new object from f

   - procedure CopySearchRec(const f: TSearchRec);
     Copies data from f



   EDosType
   --------
   Extra Dos functions type.
   This object provides additional dos functions.

   - GetWindowsDirectory: string;
     Wrapper for the win32 API function, GetWindowsDirectory.
     returns the string.

   - function GetPathFromTree(const TreeView : TTreeView; const TreeNode : TTreeNode) : string;
     Constructs a directory path to Tree Node, seperated by '\'
     Note: If there  is a customised one, (eg. DirTreeForm) don't use this.

   - function HasSubDir(var S : string) : boolean;
     True if the directory, S, has a sub directory.

   - FileExists (Under SysUtils)

   - Path exists (Use DirectoryExists Delphi 4)
     true if a file/drive/directry exists.
     To check for a drive, use 'c:'. Do not append a slash.

   - ForceDirectories
     ripped from FileCtrl
     will raise EInOutError if dir cannot be created e.g. drive not ready


   - function ShowErrorMessageBox(const ErrorCode: integer): integer;
     Shows a meaningful message (if available) for the ErrorCode.
     Check help for "Error Codes". Returns the user's reponse from the
     message box eg. IDRETRY, IDCANCEL.
     Note: The message will not be shown if there is no error ie. ErrorCode = 0.
-------------------------------------------------------------------------------}




(**) interface (**)
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, ComCtrls, ShellAPI,
  FileCtrl,
  // for SCannotCreateDir
  Consts;


type
  TFilePos = Longint;

  TDriveList = class
  private
    CurrPos: integer;          // current position in DriveStr
    EndOfList: boolean;        // true when end of list is reached.
  public
    DriveStr: PChar;           // string of drive letters gotten from GetLogicalDrivesString
    constructor Create;
    destructor destroy; override;

    function Next: string;
    {Returns the next drive string, returns a null string when the
     end of the list is reached}
    procedure Reset;
    {restart}
  end;


  (* TEnhSearchRec = class
  public
    constructor CreateFrom(const f: TSearchRec);
    procedure CopySearchRec(const f: TSearchRec);

    function IsArchive: boolean;
    function IsReadOnly: boolean;
    function IsSysFile: boolean;
    function IsHidden: boolean;
    function IsFolder: boolean;
  private
    FCreationTime,
    FLastAccessTime,
    FLastWriteTime: TDateTime;
    FSize: Integer;
    FAttr: Integer;
    FName: TFileName;

    {Time functions}
    function Win32FileTimeToDosDateTime(const ftime: TFileTime): integer;

  published
    property Size: Integer read FSize;
    property Attr: Integer read FAttr;
    property Name: TFileName read FName;
    property CreationTime: TDateTime read FCreationTime;
    property LastAccessTime: TDateTime read FLastAccessTime;
    property LastWriteTime: TDateTime read FLastWriteTime;
  end; *)


  EDosType = class
  public
    {defunct}
    {function GetPathFromTree(const TreeNode: TTreeNode) : string;}

    {Directory related functions}
    function GetWindowsDirectory: string;
    function HasSubDir(const S: string): boolean;
    procedure AddSlash(var s: string);
    procedure DelSlash(var s: string);

    procedure DelTree(dir: string);
    procedure ForceDirectories(Dir: string);
    function PathExists(const s: string): boolean;
    function ExtractFolders(s: string): string;
    {function FileExists(const S: string): boolean;
    procedure CreatePath(const s: string);}

    {FindFirst/FindNext}
    function FindFirst(const Path: string; Attr: Integer; var F: TSearchRec): Integer;
    function FindNext(var F: TSearchRec): Integer;
    procedure FindClose(var F: TSearchRec);

    function GetSysImageList: TImageList;

    {Error support}
    function TestIO(const val: integer): boolean;
  end;

var
  EDos : EDosType;

(**) implementation (**)

////////////////////////////////////////////////////////////////////////////////
// TDriveList
////////////////////////////////////////////////////////////////////////////////

const
  DriveStrSize = 1000;            // size of the DriveStr variable

constructor TDriveList.create;
begin
  GetMem(DriveStr, DriveStrSize);
  GetLogicalDriveStrings(DriveStrSize, DriveStr);
  CurrPos := 0;
  EndOfList := false;
end;

destructor TDriveList.destroy;
begin
  FreeMem(DriveStr);
end;

function TDriveList.Next: string;
begin
  result := '';
  if (ord(DriveStr[CurrPos]) = 0) or EndOfList then
  begin
    EndOfList := true;
    exit;
  end;

  while (ord(DriveStr[CurrPos]) <> 0) do
  begin
    result := result + DriveStr[CurrPos];
    inc(CurrPos);
  end;
  inc(CurrPos); {Next position to start reading from}
end;

procedure TDriveList.Reset;
begin
  CurrPos := 0;
  EndOfList := false;
end;


////////////////////////////////////////////////////////////////////////////////
// TEnhSearchRec
////////////////////////////////////////////////////////////////////////////////
(* constructor TEnhSearchRec.CreateFrom(const f: TSearchRec);
begin
  inherited create;
  CopySearchRec(f);
end;

procedure TEnhSearchRec.CopySearchRec(const f: TSearchRec);
begin
  FSize := f.Size;
  FAttr := f.Attr;
  FName := f.Name;
  FLastWriteTime := FileDateToDateTime(f.Time);
//  FCreationTime := FileDateToDateTime(Win32FileTimeToDosDateTime(f.FindData.ftCreationTime));
//  FLastAccessTime := FileDateToDateTime(Win32FileTimeToDosDateTime(f.FindData.ftLastAccessTime));
end;

function TEnhSearchRec.IsFolder: boolean;
begin
  result := (Attr and faDirectory <> 0);
end;

function TEnhSearchRec.IsArchive: boolean;
begin
  result := (Attr and faArchive <> 0);
end;

function TEnhSearchRec.IsReadOnly: boolean;
begin
  result := (Attr and faReadOnly <> 0);
end;

function TEnhSearchRec.IsSysFile: boolean;
begin
  result := (Attr and faSysFile <> 0);
end;

function TEnhSearchRec.IsHidden: boolean;
begin
  result := (Attr and faHidden <> 0);
end;

function TEnhSearchRec.Win32FileTimeToDosDateTime(const ftime: TFileTime): integer;
var
  LocalFileTime: TFileTime;
  Time: integer;
begin
  FileTimeToLocalFileTime(ftime, LocalFileTime);
  FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi,
    LongRec(Time).Lo);
  result := Time;
end;
*)


////////////////////////////////////////////////////////////////////////////////
// EDosType
////////////////////////////////////////////////////////////////////////////////




function EDosType.GetWindowsDirectory: string;
var
  c: PChar;    {PChar to get the directory}
const
  cLength = MAX_PATH;     {Length of c}
begin
  c := StrAlloc(cLength + 1);
  windows.GetWindowsDirectory(c, cLength);
  result := c;
  StrDispose(c);
end;

procedure EDosType.AddSlash(var s: string);
var
  len: integer;
begin
  len := length(s);
  if (len > 0) and (s[len] <> '\') then
    s := s + '\';
end;

procedure EDosType.DelSlash(var s: string);
var
  len: integer;
begin
  len := Length(s);
  if (len > 0) and (s[len] = '\') then
    delete(S, len, 1);
end;


function EDosType.HasSubDir(const S : string) : boolean;
var
  F : TSearchRec;
  rc : integer;
  found : boolean;
begin
  found := false;
  rc := FindFirst(S + '*.*', faDirectory, F);
  while (rc = 0) do begin
    if (F.Attr and faDirectory <> 0) and (F.Name[1] <> '.') then begin
      found := True;
      break;
    end;
    rc := FindNext(F);
  end;
  FindClose(F);
  result := found;
end;

(*
function EDosType.GetPathFromTree(const TreeNode : TTreeNode) : string;
var
  rs : string;
  WorkNode : TTreeNode;
begin
  rs := '';
  WorkNode := TreeNode;
  while (WorkNode <> nil) do begin
    rs := rCheckDirStr(WorkNode.Text) {+ '\'} + rs;
    WorkNode := WorkNode.Parent;
  end;
  result := rs;
end;
*)

{$I-}
{Path exists checks for drive, file or directory}
function EDosType.PathExists(const s: string): boolean;
var
  F: TSearchRec;
  ws: string;
  curDir: string;
begin
  // create a working copy
  ws := s;
  DelSlash(ws);

  // test for eg 'c:', 'z:', 'x:'
  if (ws[2] = ':') and (length(ws) <= 2) then
  begin
    //drive
    GetDir(0, curDir);
    CHDir(ws);
    result := (ioResult = 0);
    CHDir(curDir);
  end
  else
  begin
    // File or dir
    result := (FindFirst(ws, faAnyFile, F) = 0);
    FindClose(F);
  end;
end;

procedure EDosType.DelTree(dir: string);
var
  F: TSearchRec;
  r: integer;
  CurFileStr: string;
begin
  r := FindFirst(dir + '\*.*', faAnyFile - faVolumeID, F);
  while (r = 0) do
  begin
    with F do
    begin
      CurFileStr := dir + '\' + Name;
      // test if it is a directory
      if (Attr and faDirectory <> 0) then
      begin
        // if it is a directory we rescurse into it
        if (Name[1] <> '.') then
          DelTree(CurFileStr);
      end
      else
      begin
        // test if it has a read only or system attribute which
        // may hinder deletion. clear it.
        // DO: IMPLEMENT EXCEPTION CHECKING FILESETATTR and DELETEFILE
        if (Attr and faReadOnly <> 0) or
           (Attr and faHidden <> 0) or
           (Attr and faSysFile <> 0) then
           FileSetAttr(CurFileStr, 0);
        DeleteFile(CurFileStr);
      end;
    end;

    r := FindNext(F); 
  end;

  // remove the empty dir
  RmDir(dir);
  FindClose(F);
end;


procedure EDosType.ForceDirectories(Dir: string);
begin
  FileCtrl.ForceDirectories(Dir);
  if not DirectoryExists(Dir) then
    raise EInOutError.Create('Cannot force directory');
    
  {if Length(Dir) = 0 then
    raise Exception.Create(SCannotCreateDir);
  if (AnsiLastChar(Dir) <> nil) and (AnsiLastChar(Dir)^ = '\') then
    Delete(Dir, Length(Dir), 1);
  if (Length(Dir) < 3) or DirectoryExists(Dir)
    or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
  ForceDirectories(ExtractFilePath(Dir));
  if not CreateDir(Dir) then
    raise EInOutError.Create('Cannot force directory');}
end;


function EDosType.GetSysImageList: TImageList;
var
  SysImageList: TImageList;
  FileInfo: TSHFileInfo;
begin
  SysImageList := TImageList.create(Application);
  with SysImageList do
  begin
    handle := SHGetFileInfo(PChar(EDos.GetWindowsDirectory), 0, FileInfo, sizeof(FileInfo), SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
    ShareImages := true;
  end;
  result := SysImageList;
end;

function EDosType.FindFirst(const Path: string; Attr: Integer; var F: TSearchRec): Integer;
begin
  repeat
    result := SysUtils.FindFirst(Path, Attr, F);
  until TestIO(result);
end;

function EDosType.FindNext(var F: TSearchRec): Integer;
begin
  repeat
    result := SysUtils.FindNext(F);
  until TestIO(result);
end;

procedure FileSetAttr(const FileName: string; Attr: Integer);
var
  retval: integer;
begin
  retval := SysUtils.FileSetAttr(FileName, Attr);
  if (retval <> 0) then
    raise EInOutError.Create('FileSetAttr error');
end;

procedure DeleteFile(const FileName: string);
begin
  if (SysUtils.DeleteFile(FileName) = false) then
    raise EInOutError.Create('DeleteFile error');
end;



procedure EDosType.FindClose(var F: TSearchRec);
begin
  SysUtils.FindClose(F);
end;

{-------------------------------------------------------------------------------
  TestIO

  Desc: Will test the IO return value val for error.
  Returns True if IO is OK.
          False means the operation should retry
  If the user cancelled, then EInOutError will be raised with the error description
-------------------------------------------------------------------------------}
function EDosType.TestIO(const val: integer): boolean;
var
  Caption: string;
  ErrorDesc: string;
  HelpStr: string;
  flags : integer;
begin
  if (val  = 0) OR
    (val = ERROR_NO_MORE_FILES) then
    result := true
  else
  begin
    // give user choice of retrying
    // the function will return a false indicating a retry
    // otherwise if the user cancelled, then an EInOutError will be returned

    Caption := 'Error';
    ErrorDesc := '';
    HelpStr := '';

    case val of
      // the error consts are taken from the Windows unit
      
      ERROR_PATH_NOT_FOUND:
      begin
        ErrorDesc := 'Path not found.';
        //HelpStr := 'Try re-reading the directory.';
      end;
      ERROR_NOT_READY: {21: drive not ready}
      begin
        ErrorDesc := 'Drive not ready.';
        HelpStr := 'Make sure the disk is properly inserted.';
      end;

      else
      begin
        ErrorDesc := 'No error description available.';
        HelpStr := 'Choose ''Retry'' to retry the last operation.';
      end;
    end;

    {Display the error code also}
    flags := MB_ICONERROR or MB_RETRYCANCEL;

    if (Application.MessageBox(PChar(ErrorDesc + #13 + HelpStr + ' (Error code: ' + IntToStr(val) + ')'),
      PChar(Caption), flags) = IDRetry) then
      result := false
    else
      raise EInOutError.Create(Caption);
  end;
end;


{File exists checks if a file exists. Dirs and drives are not counted.
Now defunct. exists in SysUtils.}
{function EDosType.FileExists(const s: string): boolean;
var
  F: TSearchRec;
  ws: string;
  r: integer;
begin
  // create a working copy
  ws := s;
  DelSlash(ws);

  r := FindFirst(ws, faAnyFile, F);
  while (r = 0) do
  begin
    if (F.Attr and faDirectory = 0) then
    begin
      result := true;
      FindClose(F);
      exit;
    end;
    r := FindNext(F);
  end;

  result := false;
  FindClose(F);
end;}

(* CreatePath
Don't think this works. Use ForceDirectories
{$I+}

procedure EDosType.CreatePath(const s: string);
var
  i, path_length: integer;
  next_dir: string;

  function GetNextDir: string;
  begin
    next_dir := '';
    while (i < path_length) and  (s[i] <> '\') do
    begin
      next_dir := next_dir + s[i];
      inc(i);
    end;

    // skip the '\'
    inc(i);
  end;

begin
  i := 1;
  path_length := length(s);

  {$I-}
  GetNextDir;

  // make sure the drive is passed
  Assert(next_dir[2] = ':', 'CreatePath: Drive not passed.');

  // change to drive first. '\' added to change to root.
  CHDir(next_dir + '\');
  if (IOResult <> 0) then raise EInOutError.Create('CreatePath: Cannot change to drive');

  GetNextDir;
  while (next_dir <> '') do
  begin
    CHDir(next_dir);
    if (IOResult <> 0) then
    begin
      // directory does not exist.
      // try to create it.
      MKDir(next_dir);
      if (IOResult <> 0) then raise EInOutError.Create('CreatePath: Cannot create directory');
    end
    else
      GetNextDir;

  end;

  {$I+}
end; *)



function EDosType.ExtractFolders(s: string): string;
begin
  // returns the folders only
  // same as ExtractPath but without the drive
  s := ExtractFilePath(s);
  if (s[2] = ':') then delete(s, 1, 2);
  if s[1] = '\' then delete(s, 1, 1);
  result := s;
end;

initialization
  EDos := EDosType.Create;
finalization
  EDos.free;
end.