Changed delete $h->{$key} to work for keys with 'private_' prefix RT#83156

Author: timbunce

Changes

@@ -14,6 +14,9 @@ DBI::Changes - List of significant changes to the DBI
         driver_prefix is not fulfilled (RT#93204) [Jens Rehsack]
     Fixed redundant sprintf argument warning RT#97062 [Reini Urban]
 
+    Changed delete $h->{$key} to work for keys with 'private_' prefix
+        per request in RT#83156. local $h->{$key} works as before.
+
     Added security notice to DBD::Proxy and DBI::ProxyServer because they
         use Storable which is insecure. Thanks to [email protected] RT#90475
 

DBI.pm

@@ -411,6 +411,7 @@ my $keeperr = { O=>0x0004 };
 	'FIRSTKEY'	=> $keeperr,
 	'NEXTKEY'	=> $keeperr,
 	'STORE'		=> { O=>0x0418 | 0x4 },
+	'DELETE'	=> { O=>0x0404 },
 	can		=> { O=>0x0100 }, # special case, see dispatch
 	debug 	 	=> { U =>[1,2,'[$debug_level]'],	O=>0x0004 }, # old name for trace
 	dump_handle 	=> { U =>[1,3,'[$message [, $level]]'],	O=>0x0004 },

DBI.xs

@@ -5445,6 +5445,19 @@ FETCH(h, keysv)
     ST(0) = dbih_get_attr_k(h, keysv, 0);
     (void)cv;
 
+void
+DELETE(h, keysv)
+    SV *        h
+    SV *        keysv
+    CODE:
+    /* only private_* keys can be deleted, for others DELETE acts like FETCH */
+    /* because the DBI internals rely on certain handle attributes existing  */
+    if (strnEQ(SvPV_nolen(keysv),"private_",8))
+        ST(0) = hv_delete_ent((HV*)SvRV(h), keysv, 0, 0);
+    else
+        ST(0) = dbih_get_attr_k(h, keysv, 0);
+    (void)cv;
+
 
 void
 private_data(h)

lib/DBI/PurePerl.pm

@@ -893,6 +893,11 @@ sub STORE {
     $h->{$key} = $is_flag_attribute{$key} ? !!$value : $value;
     return 1;
 }
+sub DELETE {
+    my ($h, $key) = @_;
+    return $h->FETCH($key) unless $key =~ /^private_/;
+    return delete $h->{$key};
+}
 sub err    { return shift->{err}    }
 sub errstr { return shift->{errstr} }
 sub state  { return shift->{state}  }

t/06attrs.t

@@ -79,6 +79,13 @@ is_deeply [ $dbh->FETCH_many(qw(HandleError FetchHashKeyName LongReadLen ErrCoun
           [ undef, qw(NAME 80 0) ], 'should be able to FETCH_many';
 
 is $dbh->{examplep_private_dbh_attrib}, 42, 'should see driver-private dbh attribute value';
+is delete $dbh->{examplep_private_dbh_attrib}, 42, 'delete on non-private attribute acts like fetch';
+is $dbh->{examplep_private_dbh_attrib}, 42, 'value unchanged after delete';
+
+$dbh->{private_foo} = 42;
+is $dbh->{private_foo}, 42, 'should see private_foo dbh attribute value';
+is delete $dbh->{private_foo}, 42, 'delete should return private_foo dbh attribute value';
+is $dbh->{private_foo}, undef, 'value of private_foo after delete should be undef';
 
 # Raise an error.
 eval {