Добавить, удалить папку из IShellLibrary

Проблема здесь в том, что инженер Embarcadero, который перевел SHAddFolderPathToLibrary, не понимает подсчета ссылок COM и того, как он обрабатывается разными компиляторами.

Вот как SHAddFolderPathToLibrary реализовано в заголовочном файле C++ Shobjidl.h. На самом деле это встроенная оболочка других основных вызовов API:

__inline HRESULT SHAddFolderPathToLibrary(_In_ IShellLibrary *plib, 
    _In_ PCWSTR pszFolderPath)
{
    IShellItem *psiFolder;
    HRESULT hr = SHCreateItemFromParsingName(pszFolderPath, NULL, 
        IID_PPV_ARGS(&psiFolder));
    if (SUCCEEDED(hr))
    {
        hr = plib->AddFolder(psiFolder);
        psiFolder->Release();
    }
    return hr;
}

И дельфийский перевод очень точен, даже слишком точен:

function SHAddFolderPathToLibrary(const plib: IShellLibrary;
  pszFolderPath: LPCWSTR): HResult;
var
  psiFolder: IShellItem;
begin
  Result := SHCreateItemFromParsingName(pszFolderPath, nil, IID_IShellItem,
    psiFolder);
  if Succeeded(Result) then
  begin
    Result := plib.AddFolder(psiFolder);
    psiFolder._Release();
  end;
end;

Проблема заключается в вызове _Release. Компилятор Delphi управляет подсчетом ссылок, поэтому этот явный вызов _Release является поддельным и не должен быть здесь. Поскольку компилятор организует вызов _Release, этот лишний вызов просто нарушит баланс подсчета ссылок. Причина, по которой _AddRef и _Release имеют префикс _, состоит в том, чтобы напомнить людям не вызывать их и позволить компилятору сделать это.

Вызов Release в версии C++ точен, потому что компиляторы C++ не вызывают автоматически Release за вас, если вы не оберните интерфейс в смарт-указатель COM. Но инженер Embarcadero слепо скопировал его, и последствия остались за вами. Ясно, что этот код даже никогда не выполнялся инженерами Embarcadero.

Вам нужно будет предоставить собственную исправленную реализацию этой функции. А также любую другую ошибочно переведенную функцию. Найдите _Release в блоке ShlObj и удалите их в исправленных версиях. В переводе есть и другие ошибки, так что будьте осторожны. Например, SHLoadLibraryFromItem (и другие) объявляют локальную переменную plib: ^IShellLibrary, которая должна быть plib: IShellLibrary.

Я отправил отчет контроля качества: QC#117351.

Я придумал свой алгоритм, который предлагаю здесь, нерекурсивный, который занимает очень мало памяти и удаляет папки любой глубины и файл(ы) со специальными атрибутами. К сожалению, комментарии все еще на итальянском языке. Чтобы объяснить, как это работает: вы должны инициализировать удаление файла или папки с помощью процедуры InitDelT (Dir: String; Var DelTRec: TDelTRec); и запустить несколько раз, например, в своего рода цикле, функцию DelT (Var DelTRec: TDelTRec): Byte;, которая возвращает: 2 -> Deletion completed successfully. 3 -> Deletion failed. Переменная DelTRec: TDelTRec содержит: PathName, BaseDir, Msg: String; Status: Byte; {Status: 0 -> Deleting (no items deleted yet). 1 -> Deleting (1 item just deleted). 2 -> Deletion completed successfully. 3 -> Deletion failed}.

Unit DelTU;

Interface

Type TDelTRec=Record
      PathName,BaseDir,Msg:String;
      Status:Byte;
     {Status: 0 -> Eliminazione in corso (nessun elemento ancora eliminato).
              1 -> Eliminazione in corso (1 elemento appena eliminato).
              2 -> Eliminazione terminata con successo.
              3 -> Eliminazione fallita}
     End;

Function  KeepExtendedDir    (Dir:String):String;

{Preleva la Dir non normalizzata
 (con BACKSLASH) da Dir.

 NOTE: Non effettua alcun accesso ad UNITà A DISCO}

Function  KeepNormDir        (Dir:String):String;

{Preleva la Dir normalizzata
 (senza BACKSLASH) da Dir.

 NOTE: Non effettua alcun accesso ad UNITà A DISCO}

Function  GetPathNameDir     (PathName:String):String;

{Ritorna l' UNITà ed il PERCORSO DI PathName}

Procedure FileSplit          (FileName:String;
                              Var Drive,Dir,Name,Ext:String);

{Scompone un PERCORSO DI FILE FileName
 IN UNITà (DRIVE), Dir (Dir), nome (Name)
 ed estensione (Ext).

 NOTE: Non effettua alcun accesso ad UNITà A DISCO}

Procedure FSplit             (FileName:String;
                              Var Dir,Name,Ext:String);

{Scompone un PERCORSO DI FILE FileName
 Path (Dir), nome (Name)
 ed estensione (Ext).

 NOTE: Non effettua alcun accesso ad UNITà A DISCO}

Function  Is_Drive_Or_Root  (Dir:String):Boolean;

{Verifica Se la Dir specificata da Dir è
 una ROOT Dir o un DRIVE (IN questo caso ritorna TRUE).

 Ritorna FALSE Se Dir è una Sub-DIRECTORY}

Function  File_Exists_Sub    (FileName:String;Attr:Integer;
                              Var Attr_Read:Integer):Boolean;

{Verifica che un FILE o una Dir FileName esista
 ed abbia attributi compresi IN Attr.
 Se FileName ha uno o più attributi che differiscono da Attr, ritorna FALSE.
 Se FileName non ha attributi, ritorna TRUE.

 Ritorna FALSE solo IN caso DI ERRORE,
 altrimenti Attr_Read contiene gli attributi DI FileName.

 NOTE: Per trovare qualsiasi FILE:

       Attr= faAnyFile-
             faVolumeId-
             faDirectory.

       Per trovare qualsiasi FILE E DIRECTORY:

       Attr= faAnyFile-
             faVolumeId.

       Per trovare qualsiasi DIRECTORY:

       Found:=File_Exists_Sub(FileName,faAnyFile-faVolumeId,Attr_Read) AND
              ((Attr_Read AND faDirectory)<>0)}

Function  File_Exists        (FileName:String):Boolean;

(* Controlla che FileName sia un FILE esistente *)

Function  Dir_Exists         (FileName:String):Boolean;

(* Controlla che FileName sia una DIRECTORY esistente *)

Function  FDel               (Source:String):Boolean;

(* Rimuove qualsiasi file, anche con attributi speciali;
   non imposta ErrorMsg *)

Function  RmDir              (Source:String):Boolean;

(* Rimuove qualsiasi directory vuota, anche con attributi speciali;
   non imposta ErrorMsg *)

Procedure InitDelT           (Dir:String;
                              Var DelTRec:TDelTRec);

{Inizializzazione funzione "remove not empty folder" alias DelT().

 Dir è il percorso assoluto della cartella da rimuovere;
 può essere specificato anche senza il backslash finale.

 Nel caso Dir non esista, questa funzione disabilita la rimozione;
 altrimenti essa potrà avvenire in background, chiamando DelT()}

Function  DelT               (Var DelTRec:TDelTRec):Byte;

{Funzione "remove not empty folder" alias DelT().

 La rimozione potrà avvenire in background, chiamando DelT() dopo
 aver inizializzato DelTRec con InitDelT().

 Ritorna: 0 -> Eliminazione in corso (nessun elemento ancora eliminato).
          1 -> Eliminazione in corso (1 elemento appena eliminato).
          2 -> Eliminazione terminata con successo.
          3 -> Eliminazione fallita.

 ALGORITMO:
 ---------:
 - specificare full-path-name PathName con filtro *.*;
   es.: c:\programs.pf\graphic.pf\*.*
 - Copiare nella base-path BaseDir il percorso della cartella da rimuovere;
   es.: c:\programs.pf

 - RemoveDir <- False.
 - Preleva FileName1 e Dir da PathName.
 - Se FileName1="<Rm_Dir>":
   - RemoveDir <- True.
   - Preleva FileName1 e Dir da Dir (normalizzata).
 - NoSuchFile1 <- False
 - Cerca la prima ricorrenza di FileName1 in Dir.:
   - Imposta NoSuchFile1 <- True, se non esiste.
 - NoSuchFile2 <- True
 - SetFileName2 <- False
 - Se NoSuchFile1 = False:
   - Cerca il file o dir. successivo FileName2 in Dir:
     - Imposta NoSuchFile2 <- True, se non esiste.
   - Se RemoveDir=True:
     - Rimuove la dir. FileName1
     - Se Dir=BaseDir, ha finito.
     - SetFileName2 <- True
   - Se RemoveDir=False:
     - Se FileName1 è un file:
       - Rimuove il file FileName1.
       - SetFileName2 <- True
     - Se FileName1 è una dir.:
       - Imposta PathName con Dir., FileName1 e *.*
 - Se (NoSuchFile2 = False) E SetFileName2:
   - Se FileName2 è un file, imposta PathName con Dir. e FileName2
   - Se FileName2 è una dir., imposta PathName con Dir., FileName2 e *.*
 - Se (NoSuchFile2 = True) E SetFileName2 O
      (NoSuchFile1 = True):
   - Imposta PathName con Dir. e "<Rm_Dir>"}

{-----------------------------------------------------------------------}

Implementation

Uses SysUtils;

Function KeepExtendedDir(Dir:String):String;

Var Len:Integer;

Begin
 Len:=Length(Dir);
 If (Len>0) And Not (Dir[Len] In [':','\']) Then
  KeepExtendedDir:=Dir+'\'
 Else
  KeepExtendedDir:=Dir;
End;

Function KeepNormDir(Dir:String):String;

Var Len:Integer;

Begin
 Len:=Length(Dir);
 If (Len>1) And
    (Dir[Len]='\') And
    (Dir[Len-1]<>':') Then
  KeepNormDir:=Copy(Dir,1,Len-1)
 Else
  KeepNormDir:=Dir;
End;

Function GetPathNameDir(PathName:String):String;

Var Index:Integer;

Begin
 Index:=Length(PathName);
 While (Index>0) And Not (PathName[Index] In ['\',':']) Do
  Dec(Index);
 GetPathNameDir:=Copy(PathName,1,Index);
End;

Procedure FileSplit(FileName:String;
                    Var Drive,Dir,Name,Ext:String);

Var Ch:Char;
    Index,Flag:Integer;

Begin
 Drive:='';
 Dir:='';
 Name:='';
 Ext:='';
 Flag:=0;
 Index:=Length(FileName);
 While Index>0 Do
  Begin
   Ch:=FileName[Index];
   Case Ch Of
    '\':If Flag<3 Then
         Flag:=2;
    ':':Flag:=3;
    '.':If Flag=0 Then
         Flag:=1;
   End;
   Case Flag Of
    0:Name:=Ch+Name;
    1:If Ext='' Then
       Begin
        Ext:=Ch+Name;
        Name:='';
       End
      Else
       Name:=Ch+Name;
    2:Dir:=Ch+Dir;
    3:Drive:=Ch+Drive;
   End;
   Dec(Index);
  End;
End;

Procedure FSplit(FileName:String;
                 Var Dir,Name,Ext:String);

Var Drive:String;

Begin
 FileSplit(FileName,Drive,Dir,Name,Ext);
 Dir:=Drive+Dir;
End;

Function Is_Drive_Or_Root(Dir:String):Boolean;

Const Special_Chars:Array[Boolean] Of Char=(':','\');

Var Len:Integer;

Begin
 Len:=Length(Dir);
 Is_Drive_Or_Root:=((Len=1) Or (Len=2) Or (Len=3) And (Dir[2]=':')) And
                   (Dir[Len]=Special_Chars[Odd(Len)]);
End;

Function File_Exists_Sub(FileName:String;Attr:Integer;
                         Var Attr_Read:Integer):Boolean;

(* per trovare qualsiasi FILE:

   Attr= faAnyFile-
         faVolumeId-
         faDirectory *)

Var TempOut:Boolean;
    SR:TSearchRec;

Begin
 Attr_Read:=0;
 TempOut:=((Attr And faDirectory)<>0) And
          Is_Drive_Or_Root(FileName);
 If Not TempOut And
    (FindFirst(FileName,Attr,SR)=0) Then
  Begin
   TempOut:=True;
   Attr_Read:=SR.Attr;
   FindClose(SR);
  End;
 File_Exists_Sub:=TempOut;
End;

Function File_Exists(FileName:String):Boolean;

Var Attr_Read:Integer;

Begin
 File_Exists:=File_Exists_Sub(FileName,SysUtils.faAnyFile-
                                       SysUtils.faVolumeId-
                                       SysUtils.faDirectory,
                              Attr_Read);
End;

Function Dir_Exists(FileName:String):Boolean;

Var Attr_Read:Integer;

Begin
 Dir_Exists:=File_Exists_Sub(FileName,SysUtils.faAnyFile-
                                      SysUtils.faVolumeId,
                             Attr_Read) And
             ((Attr_Read And faDirectory)<>0);
End;

Function FDel(Source:String):Boolean;

Var Attr:Integer;

Begin
 FDel:=False;
 Source:=KeepNormDir(Source);
 Attr:=SysUtils.FileGetAttr(Source);
 If (Attr And SysUtils.faDirectory)=0 Then
  Begin
   If (Attr And (SysUtils.faReadOnly+
                 SysUtils.faHidden+
                 SysUtils.faSysFile))<>0 Then
    SysUtils.FileSetAttr(Source,
                         Attr And Not (SysUtils.faReadOnly+
                                       SysUtils.faHidden+
                                       SysUtils.faSysFile));
   FDel:=DeleteFile(Source);
  End;
End;

Function RmDir(Source:String):Boolean;

Var Attr:Integer;

Begin
 RmDir:=False;
 Source:=KeepNormDir(Source);
 Attr:=SysUtils.FileGetAttr(Source);
 If (Attr And SysUtils.faDirectory)<>0 Then
  Begin
   If (Attr And (SysUtils.faReadOnly+
                 SysUtils.faHidden+
                 SysUtils.faSysFile))<>0 Then
    SysUtils.FileSetAttr(Source,
                         Attr And Not (SysUtils.faReadOnly+
                                       SysUtils.faHidden+
                                       SysUtils.faSysFile));
   RmDir:=RemoveDir(Source);
  End;
End;

Procedure InitDelT(Dir:String;
                   Var DelTRec:TDelTRec);

Begin
 With DelTRec Do
  Begin
   PathName:=KeepExtendedDir(Dir)+'*.*';
   Dir:=KeepNormDir(Dir);
   Status:=3 And -Byte(Not Dir_Exists(Dir));
   BaseDir:=GetPathNameDir(Dir);
   Msg:='';
  End;
End;

Function DelT(Var DelTRec:TDelTRec):Byte;

Var RemoveDir,SuchFile1,SuchFile2,SetFileName2,FF:Boolean;
    Dir,Name,Ext:String;
    SR1,SR2:TSearchRec;

Begin
 With DelTRec Do
  Begin
   If Status<2 Then
    Begin
     Status:=0;
     RemoveDir:=False;
     FSplit(PathName,Dir,Name,Ext);
     If Name+Ext='<Rm_Dir>' Then
      Begin
       RemoveDir:=True;
       FSplit(KeepNormDir(Dir),Dir,Name,Ext);
      End;
     FF:=FindFirst(Dir+'*.*',
                   SysUtils.faAnyFile-
                   SysUtils.faVolumeId,SR2)=0;
     SuchFile1:=FF;
     While SuchFile1 And
           ((SR2.Name='.') Or (SR2.Name='..')) Do
      SuchFile1:=FindNext(SR2)=0;
     SuchFile2:=False;
     SetFileName2:=False;
     If SuchFile1 Then
      Begin
       SR1:=SR2;
       SuchFile2:=FindNext(SR2)=0;
       If RemoveDir Then
        Begin
         Msg:=Dir+Name+Ext;
         If Not RmDir(Msg) Then
          Status:=3
         Else
         If Dir=BaseDir Then
          Status:=2
         Else
          Status:=1;
         SetFileName2:=True;
        End
       Else
       If (SR1.Attr And SysUtils.faDirectory)=0 Then
        Begin
         Msg:=Dir+SR1.Name;
         If FDel(Msg) Then
          Status:=1
         Else
          Status:=3;
         SetFileName2:=True;
        End
       Else
        PathName:=Dir+SR1.Name+'\*.*';
      End;
     If SuchFile2 And SetFileName2 Then
     If (SR2.Attr And SysUtils.faDirectory)=0 Then
      PathName:=Dir+SR2.Name
     Else
      PathName:=Dir+SR2.Name+'\*.*';
     If Not SuchFile2 And SetFileName2 Or Not SuchFile1 Then
      PathName:=Dir+'<Rm_Dir>';
     If FF Then
      FindClose(SR2);
    End;
   DelT:=Status;
  End;
End;

End.

Это пример (DelTUT.DPR):

program DelTUT;

{$APPTYPE CONSOLE}

uses SysUtils,
     DelTU in 'DelTU.pas';

Var  DelTRec:TDelTRec;
     Dir:String;

begin
 { TODO -oUser -cConsole Main : Insert code here }
 WriteLn('Insert the full path-name of the folder to remove it:');
 ReadLn(Dir);
 WriteLn('Press ENTER to proceed ...');
 InitDelT(Dir,DelTRec);
 WriteLn('Removing...');
 While Not (DelT(DelTRec) In [2,3]) Do
  Write(#13,DelTRec.Msg,#32);
 WriteLn;
 If DelTRec.Status=3 Then
  WriteLn('Error!')
 Else
  WriteLn('Ok.')
end.