View Issue Details

IDProjectCategoryView StatusLast Update
0035132FPCFCLpublic2019-04-03 15:50
ReporterBart BroersmaAssigned ToMichael Van Canneyt 
PrioritynormalSeverityminorReproducibilityalways
Status closedResolutionfixed 
Platformi386OSWindowsOS Version10
Product Version3.3.1Product Buildr41343 
Target Version3.2.0Fixed in Version3.3.1 
Summary0035132: TRegistry.DeleteKey inconsistent behaviour Windows vs other platforms
DescriptionOn non-windows platforms TRegistry uses a TXMLRegistry.
If you use DeleteKey(Key) on Wondows it will only delete Key if Key has no subkeys.
The XML implementation however hapilly removes the Key including all subkeys.
Steps To ReproduceBuild and run attached example.
Expected output: EAssertionFailed: DeleteKey('One') failed. (delkey.pp, line 51)

On Linux however (an presumably all non-Windows platform it runs to the end.
And it will create the following xml:

<?xml version="1.0" encoding="utf-8"?>
<XMLReg>
  <Key Name="HKEY_CURRENT_USER">
    <Key Name="Software">
      <Key Name="TESTDELTREE">
        <Value Name="0" Type="2">0</Value>
      </Key>
    </Key>
  </Key>
</XMLReg>

TagsNo tags attached.
Fixed in Revision41817
FPCOldBugId
FPCTarget
Attached Files
  • delkey.pp (3,158 bytes)
    program deltree;
    
    {$apptype console}
    {$assertions on}
    {$ifdef fpc}
    {$mode objfpc}
    {$h+}
    {$endif fpc}
    
    uses
      SysUtils, Classes, Registry
      {$ifndef fpc}, windows{$endif !fpc};
    
    
    var
      R: TRegistry;
      B: Boolean;
      SL: TStringList;
      i: Integer;
      S: String;
    begin
      R := TRegistry.Create(KEY_ALL_ACCESS);
      try
        R.RootKey := HKEY_CURRENT_USER;
    
        B := R.OpenKey('Software\TESTDELTREE', True);
        Assert(B,'OpenKey(Software\TESTDELTREE) failed.');
    
        R.WriteString('0','0');
        B := R.OpenKey('One',True);
        Assert(B,'OpenKey(One) failed.');
        R.WriteString('1','1');
    
        B := R.OpenKey('Two',True);
        Assert(B,'OpenKey(Two) failed.');
        R.WriteString('2','2');
    
        B := R.ValueExists('2');
        Assert(B,'ValueExists(''2'') failed.');
    
        R.CloseKey;
    
        B := R.OpenKey('SoftWare\TESTDELTREE\One\Two',False);
        Assert(B,'OpenKey(''Software\TESTDELTREE\One\Two'') failed.');
    
        R.CloseKey;
        B := R.OpenKey('SoftWare\TESTDELTREE',False);
        Assert(B,'OpenKey(''Software\TESTDELTREE'') failed.');
    
        B := R.DeleteKey('One');
        Assert(B,'DeleteKey(''One'') failed.');
      finally
        R.Free;
      end;
    end.
    
    
    {
    function DeleteKeyEx(const Root: HKEY; const KeyName: string): boolean;
    const
      Registry: TRegistry = nil;
    
      function DoDeleteKey(const Start: string): boolean;
      const
        Val: TStringList = nil;
        var i: integer;
      begin
        Result := False;
        if Start <> '' then
        with Registry do
          if DeleteKey(Start) then Result := True
        else
          if OpenKey(Start, False) and HasSubKeys then
        try
          Val := TStringList.Create;
          GetValueNames(Val);
          for i := 0 to Val.Count - 1 do
            DeleteValue(Val[i]);
          Val.Clear;
            GetKeyNames(Val);
          for i := 0 to Val.Count - 1 do
            DoDeleteKey(Val[i]);
        finally
          Val.Free;
        end;
      end;
    begin
      try
        Registry := TRegistry.Create;
        with Registry do
        begin
          RootKey := Root;
          Result := DoDeleteKey(KeyName);
        end;
      finally
        Registry.Free;
      end;
    end;
    
    
    //https://app.zdechov.net/PascalClassLibrary/browser/Registry/UGeneralRegistry.pas?rev=392
    //https://trac.edgewall.org/wiki/TracLicense
    
    function TWinRegistry.DeleteKey(const Name: string; Recursive: Boolean
      ): Boolean;
    var
      SubKeys: TStringList;
      I: Integer;
    begin
      try
        SubKeys := TStringList.Create;
        if Recursive and OpenKey(Name, False) and HasSubKeys then begin
          GetKeyNames(SubKeys);
          for I := 0 to SubKeys.Count - 1 do
            DeleteKey(Name + '\' + SubKeys[I], True);
        end;
        Result := Registry.DeleteKey(Name);
      finally
        SubKeys.Free;
      end;
    end;
    
    
    procedure DeleteRegKey(aRoot : HKey; aPath : String);
    
    var
      SL : TStringList;
      X : Integer;
    begin
      SL := TStringList.Create;
      with TRegistry.Create do
      try
        RootKey := aRoot;
        if OpenKey(aPath,False) then begin
          GetKeyNames(SL);
          For X:=0 to SL.Count-1 do DeleteRegKey(aRoot,aPath + '\' + SL[X]);
          CloseKey;
          DeleteKey(aPath);
        end;
      finally
        Free;
        SL.Free;
      end;
    end;
    
    }
    
    delkey.pp (3,158 bytes)
  • xmlreg.deletekey.diff (856 bytes)
    Index: packages/fcl-registry/src/xmlreg.pp
    ===================================================================
    --- packages/fcl-registry/src/xmlreg.pp	(revision 41415)
    +++ packages/fcl-registry/src/xmlreg.pp	(working copy)
    @@ -231,7 +231,8 @@
     Function TXmlRegistry.DeleteKey(KeyPath : String) : Boolean;
     
     Var
    -  N : TDomElement;
    +  N, Curr : TDomElement;
    +  Node: TDOMNode;
     
     begin
      N:=FindKey(KeyPath);
    @@ -238,6 +239,15 @@
      Result:=(N<>Nil);
      If Result then
        begin
    +   //if a key has subkeys, result shall be false and nothing shall be deleted
    +   Curr:=N;
    +   Node:=Curr.FirstChild;
    +   While Assigned(Node) do
    +     begin
    +     If (Node.NodeType=ELEMENT_NODE) and (Node.NodeName=SKey) then
    +       Exit(False);
    +     Node:=Node.NextSibling;
    +     end;
        (N.ParentNode as TDomElement).RemoveChild(N);
        FDirty:=True;
        MaybeFlush;
    
    xmlreg.deletekey.diff (856 bytes)
  • tw35132.pp (1,822 bytes)
    program tw35132;
    
    {$apptype console}
    {$assertions on}
    {$ifdef fpc}
    {$mode objfpc}
    {$h+}
    {$endif fpc}
    
    uses
      SysUtils, Classes, Registry
      {$ifndef fpc}, windows{$endif !fpc};
    
    const
      BugID = 'Bug35132';
      Base = 'Software\' + BugID;
      One = 'One';
      OneFull = Base + '\' + One;
      Two = 'Two';
      TwoFull = OneFull + '\' + Two;
    
    
    procedure CleanUp(AssertionFailed: Boolean);
    var
      R: TRegistry;
      B: Boolean;
    begin
      R := TRegistry.Create(KEY_ALL_ACCESS);
      try
      R.RootKey := HKEY_CURRENT_USER;
      if R.KeyExists(TwoFull) then
      begin
        B := R. DeleteKey(TwoFull);
        if B then B := R.DeleteKey(OneFull);
        if B then B := R.DeleteKey(Base);
        if not B then
        begin
          if not AssertionFailed then
            Assert(False, 'Cleanup failed')
          else
            //assertion failure in main program happened, let that bubble up
            writeln('Cleanup failed as well, sorry...');
        end;
      end;
      finally
        R.Free;
      end;
    end;
    
    var
      R: TRegistry;
      B: Boolean;
    begin
      R := TRegistry.Create(KEY_ALL_ACCESS);
      try
        R.RootKey := HKEY_CURRENT_USER;
    
        B := R.OpenKey(Base, True);
        Assert(B,format('OpenKey(''%s'') failed.',[Base]));
    
        B := R.OpenKey('One',True);
        Assert(B,format('OpenKey(''%s'') failed.',[OneFull]));
    
        B := R.OpenKey('Two',True);
        Assert(B,format('OpenKey(''%s'') failed.',[TwoFull]));
    
        R.CloseKey;
    
        B := R.KeyExists(TwoFull);
        Assert(B,format('KeyExists(''%s'') failed.',[TwoFull]));
    
        R.CloseKey;
        B := R.OpenKey(Base,False);
        Assert(B,format('OpenKey(''%s'') failed.',[Base]));
    
        B := R.DeleteKey('One');
        Assert(not B,format('DeleteKey(''%s'') should have failed, but it succeeded.',[OneFull]));
      finally
        R.Free;
        CleanUp(ExceptObject <> nil);
      end;
    end.
    
    tw35132.pp (1,822 bytes)
  • xmlreg.deletekey.2.diff (863 bytes)
    Index: packages/fcl-registry/src/xmlreg.pp
    ===================================================================
    --- packages/fcl-registry/src/xmlreg.pp	(revision 41788)
    +++ packages/fcl-registry/src/xmlreg.pp	(working copy)
    @@ -234,7 +234,8 @@
     Function TXmlRegistry.DeleteKey(KeyPath : UnicodeString) : Boolean;
     
     Var
    -  N : TDomElement;
    +  N, Curr : TDomElement;
    +  Node: TDOMNode;
     
     begin
      N:=FindKey(KeyPath);
    @@ -241,6 +242,15 @@
      Result:=(N<>Nil);
      If Result then
        begin
    +   //if a key has subkeys, result shall be false and nothing shall be deleted
    +   Curr:=N;
    +   Node:=Curr.FirstChild;
    +   While Assigned(Node) do
    +     begin
    +     If (Node.NodeType=ELEMENT_NODE) and (Node.NodeName=SKey) then
    +       Exit(False);
    +     Node:=Node.NextSibling;
    +     end;
        (N.ParentNode as TDomElement).RemoveChild(N);
        FDirty:=True;
        MaybeFlush;
    

Activities

Bart Broersma

2019-02-21 19:17

reporter  

delkey.pp (3,158 bytes)
program deltree;

{$apptype console}
{$assertions on}
{$ifdef fpc}
{$mode objfpc}
{$h+}
{$endif fpc}

uses
  SysUtils, Classes, Registry
  {$ifndef fpc}, windows{$endif !fpc};


var
  R: TRegistry;
  B: Boolean;
  SL: TStringList;
  i: Integer;
  S: String;
begin
  R := TRegistry.Create(KEY_ALL_ACCESS);
  try
    R.RootKey := HKEY_CURRENT_USER;

    B := R.OpenKey('Software\TESTDELTREE', True);
    Assert(B,'OpenKey(Software\TESTDELTREE) failed.');

    R.WriteString('0','0');
    B := R.OpenKey('One',True);
    Assert(B,'OpenKey(One) failed.');
    R.WriteString('1','1');

    B := R.OpenKey('Two',True);
    Assert(B,'OpenKey(Two) failed.');
    R.WriteString('2','2');

    B := R.ValueExists('2');
    Assert(B,'ValueExists(''2'') failed.');

    R.CloseKey;

    B := R.OpenKey('SoftWare\TESTDELTREE\One\Two',False);
    Assert(B,'OpenKey(''Software\TESTDELTREE\One\Two'') failed.');

    R.CloseKey;
    B := R.OpenKey('SoftWare\TESTDELTREE',False);
    Assert(B,'OpenKey(''Software\TESTDELTREE'') failed.');

    B := R.DeleteKey('One');
    Assert(B,'DeleteKey(''One'') failed.');
  finally
    R.Free;
  end;
end.


{
function DeleteKeyEx(const Root: HKEY; const KeyName: string): boolean;
const
  Registry: TRegistry = nil;

  function DoDeleteKey(const Start: string): boolean;
  const
    Val: TStringList = nil;
    var i: integer;
  begin
    Result := False;
    if Start <> '' then
    with Registry do
      if DeleteKey(Start) then Result := True
    else
      if OpenKey(Start, False) and HasSubKeys then
    try
      Val := TStringList.Create;
      GetValueNames(Val);
      for i := 0 to Val.Count - 1 do
        DeleteValue(Val[i]);
      Val.Clear;
        GetKeyNames(Val);
      for i := 0 to Val.Count - 1 do
        DoDeleteKey(Val[i]);
    finally
      Val.Free;
    end;
  end;
begin
  try
    Registry := TRegistry.Create;
    with Registry do
    begin
      RootKey := Root;
      Result := DoDeleteKey(KeyName);
    end;
  finally
    Registry.Free;
  end;
end;


//https://app.zdechov.net/PascalClassLibrary/browser/Registry/UGeneralRegistry.pas?rev=392
//https://trac.edgewall.org/wiki/TracLicense

function TWinRegistry.DeleteKey(const Name: string; Recursive: Boolean
  ): Boolean;
var
  SubKeys: TStringList;
  I: Integer;
begin
  try
    SubKeys := TStringList.Create;
    if Recursive and OpenKey(Name, False) and HasSubKeys then begin
      GetKeyNames(SubKeys);
      for I := 0 to SubKeys.Count - 1 do
        DeleteKey(Name + '\' + SubKeys[I], True);
    end;
    Result := Registry.DeleteKey(Name);
  finally
    SubKeys.Free;
  end;
end;


procedure DeleteRegKey(aRoot : HKey; aPath : String);

var
  SL : TStringList;
  X : Integer;
begin
  SL := TStringList.Create;
  with TRegistry.Create do
  try
    RootKey := aRoot;
    if OpenKey(aPath,False) then begin
      GetKeyNames(SL);
      For X:=0 to SL.Count-1 do DeleteRegKey(aRoot,aPath + '\' + SL[X]);
      CloseKey;
      DeleteKey(aPath);
    end;
  finally
    Free;
    SL.Free;
  end;
end;

}
delkey.pp (3,158 bytes)

Bart Broersma

2019-02-23 16:00

reporter  

xmlreg.deletekey.diff (856 bytes)
Index: packages/fcl-registry/src/xmlreg.pp
===================================================================
--- packages/fcl-registry/src/xmlreg.pp	(revision 41415)
+++ packages/fcl-registry/src/xmlreg.pp	(working copy)
@@ -231,7 +231,8 @@
 Function TXmlRegistry.DeleteKey(KeyPath : String) : Boolean;
 
 Var
-  N : TDomElement;
+  N, Curr : TDomElement;
+  Node: TDOMNode;
 
 begin
  N:=FindKey(KeyPath);
@@ -238,6 +239,15 @@
  Result:=(N<>Nil);
  If Result then
    begin
+   //if a key has subkeys, result shall be false and nothing shall be deleted
+   Curr:=N;
+   Node:=Curr.FirstChild;
+   While Assigned(Node) do
+     begin
+     If (Node.NodeType=ELEMENT_NODE) and (Node.NodeName=SKey) then
+       Exit(False);
+     Node:=Node.NextSibling;
+     end;
    (N.ParentNode as TDomElement).RemoveChild(N);
    FDirty:=True;
    MaybeFlush;
xmlreg.deletekey.diff (856 bytes)

Bart Broersma

2019-02-23 16:46

reporter  

tw35132.pp (1,822 bytes)
program tw35132;

{$apptype console}
{$assertions on}
{$ifdef fpc}
{$mode objfpc}
{$h+}
{$endif fpc}

uses
  SysUtils, Classes, Registry
  {$ifndef fpc}, windows{$endif !fpc};

const
  BugID = 'Bug35132';
  Base = 'Software\' + BugID;
  One = 'One';
  OneFull = Base + '\' + One;
  Two = 'Two';
  TwoFull = OneFull + '\' + Two;


procedure CleanUp(AssertionFailed: Boolean);
var
  R: TRegistry;
  B: Boolean;
begin
  R := TRegistry.Create(KEY_ALL_ACCESS);
  try
  R.RootKey := HKEY_CURRENT_USER;
  if R.KeyExists(TwoFull) then
  begin
    B := R. DeleteKey(TwoFull);
    if B then B := R.DeleteKey(OneFull);
    if B then B := R.DeleteKey(Base);
    if not B then
    begin
      if not AssertionFailed then
        Assert(False, 'Cleanup failed')
      else
        //assertion failure in main program happened, let that bubble up
        writeln('Cleanup failed as well, sorry...');
    end;
  end;
  finally
    R.Free;
  end;
end;

var
  R: TRegistry;
  B: Boolean;
begin
  R := TRegistry.Create(KEY_ALL_ACCESS);
  try
    R.RootKey := HKEY_CURRENT_USER;

    B := R.OpenKey(Base, True);
    Assert(B,format('OpenKey(''%s'') failed.',[Base]));

    B := R.OpenKey('One',True);
    Assert(B,format('OpenKey(''%s'') failed.',[OneFull]));

    B := R.OpenKey('Two',True);
    Assert(B,format('OpenKey(''%s'') failed.',[TwoFull]));

    R.CloseKey;

    B := R.KeyExists(TwoFull);
    Assert(B,format('KeyExists(''%s'') failed.',[TwoFull]));

    R.CloseKey;
    B := R.OpenKey(Base,False);
    Assert(B,format('OpenKey(''%s'') failed.',[Base]));

    B := R.DeleteKey('One');
    Assert(not B,format('DeleteKey(''%s'') should have failed, but it succeeded.',[OneFull]));
  finally
    R.Free;
    CleanUp(ExceptObject <> nil);
  end;
end.
tw35132.pp (1,822 bytes)

Bart Broersma

2019-02-23 16:48

reporter   ~0114367

Test tw35132.pp attached. Should go in tests/test/packages/fcl-registry.

Bart Broersma

2019-03-31 17:12

reporter  

xmlreg.deletekey.2.diff (863 bytes)
Index: packages/fcl-registry/src/xmlreg.pp
===================================================================
--- packages/fcl-registry/src/xmlreg.pp	(revision 41788)
+++ packages/fcl-registry/src/xmlreg.pp	(working copy)
@@ -234,7 +234,8 @@
 Function TXmlRegistry.DeleteKey(KeyPath : UnicodeString) : Boolean;
 
 Var
-  N : TDomElement;
+  N, Curr : TDomElement;
+  Node: TDOMNode;
 
 begin
  N:=FindKey(KeyPath);
@@ -241,6 +242,15 @@
  Result:=(N<>Nil);
  If Result then
    begin
+   //if a key has subkeys, result shall be false and nothing shall be deleted
+   Curr:=N;
+   Node:=Curr.FirstChild;
+   While Assigned(Node) do
+     begin
+     If (Node.NodeType=ELEMENT_NODE) and (Node.NodeName=SKey) then
+       Exit(False);
+     Node:=Node.NextSibling;
+     end;
    (N.ParentNode as TDomElement).RemoveChild(N);
    FDirty:=True;
    MaybeFlush;

Bart Broersma

2019-03-31 17:12

reporter   ~0115146

Attached xmlreg.deletekey.2.diff: regenrated the patch after the massive changes of r41784.

Michael Van Canneyt

2019-04-01 19:16

administrator   ~0115169

Applied, thank you for the patch.

I converted your test program to a unit test using fpcunit.
Maybe in future also add tests to the test program in the tests directory.

Issue History

Date Modified Username Field Change
2019-02-21 19:17 Bart Broersma New Issue
2019-02-21 19:17 Bart Broersma File Added: delkey.pp
2019-02-23 16:00 Bart Broersma File Added: xmlreg.deletekey.diff
2019-02-23 16:46 Bart Broersma File Added: tw35132.pp
2019-02-23 16:48 Bart Broersma Note Added: 0114367
2019-03-31 17:12 Bart Broersma File Added: xmlreg.deletekey.2.diff
2019-03-31 17:12 Bart Broersma Note Added: 0115146
2019-04-01 19:16 Michael Van Canneyt Fixed in Revision => 41817
2019-04-01 19:16 Michael Van Canneyt Note Added: 0115169
2019-04-01 19:16 Michael Van Canneyt Status new => resolved
2019-04-01 19:16 Michael Van Canneyt Fixed in Version => 3.3.1
2019-04-01 19:16 Michael Van Canneyt Resolution open => fixed
2019-04-01 19:16 Michael Van Canneyt Assigned To => Michael Van Canneyt
2019-04-01 19:16 Michael Van Canneyt Target Version => 3.2.0
2019-04-03 15:50 Bart Broersma Status resolved => closed