Item14152: Added callback deregistration routine

Added CallbackTests test case.

Fixed a left behind bug when callback could be issued on a destroyed
object.

Merge commit 'd85280c914f5fe65affe16e3236a7c162554b346' into Item14152

* commit 'd85280c914f5fe65affe16e3236a7c162554b346':
  Item13897: Don't generate extra stack trace on fata exceptions

UnitTestContrib/test/unit/CallbackTests.pm

@@ -0,0 +1,92 @@
+# See bottom of file for license and copyright information
+
+package CBTest::Provider;
+
+use Foswiki::Class qw(callbacks);
+extends qw(Foswiki::Object);
+
+callback_names qw(testCB);
+
+sub methodWithCB {
+    my $this = shift;
+
+    $this->callback( testCB => { testParam => 'See it!', } );
+}
+
+package CBTest::Handler;
+
+use Scalar::Util qw(weaken);
+
+use Foswiki::Class qw(callbacks);
+extends qw(Foswiki::Object);
+
+sub BUILD {
+    my $this = shift;
+
+    my $params = { this => $this, };
+    weaken( $params->{this} );
+    $this->registerCallback( 'CBTest::Provider::testCB', \&cbHandler, $params );
+}
+
+sub cbHandler {
+    my $obj    = shift;
+    my %params = @_;
+
+    my $this = $params{data}{this};
+
+    say STDERR "This is handler for object ", $this->__id;
+}
+
+package CallbackTests;
+
+use Assert;
+use Foswiki::Exception ();
+
+use Foswiki::Class;
+extends qw(FoswikiFnTestCase);
+
+around BUILDARGS => sub {
+    my $orig  = shift;
+    my $class = shift;
+    return $orig->( $class, @_, testSuite => 'CallbackTests' );
+};
+
+sub test_multiObject {
+    my $this = shift;
+
+    my $provider = $this->create('CBTest::Provider');
+    my @obj;
+
+    for ( 1 .. 2 ) {
+        push @obj, $this->create('CBTest::Handler');
+    }
+
+    $provider->methodWithCB;
+
+    say "Deleting ", $obj[0]->__id;
+    delete $obj[0];
+
+    $this->leakDetectDump("CBTest");
+
+    $provider->methodWithCB;
+}
+
+1;
+__END__
+Foswiki - The Free and Open Source Wiki, http://foswiki.org/
+
+Copyright (C) 2016 Foswiki Contributors. Foswiki Contributors
+are listed in the AUTHORS file in the root of this distribution.
+NOTE: Please extend that file, not this notice.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version. For
+more details read LICENSE in the root of this distribution.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+As per the GPL, removal of this notice is prohibited.

core/lib/Foswiki/Aux/Callbacks.pm

@@ -79,6 +79,7 @@ use v5.14;
 
 use Assert;
 use Try::Tiny;
+use Scalar::Util qw(weaken);
 
 # Hash of registered callback names in a form of:
 # $_registeredNames{'Foswiki::NameSpace'}{callbackName} = 1;
@@ -95,6 +96,19 @@ around BUILD => sub {
     return $orig->( $this, @_ );
 };
 
+before DEMOLISH => sub {
+    my $this = shift;
+
+    #$this->_traceMsg("Callbacks DEMOLISH");
+
+    # Cleanup all callbacks registed by this object.
+    my $appHeap = $this->_getApp->heap;
+
+    foreach my $cbName ( keys %{ $appHeap->{_aux_registered_callbacks} } ) {
+        $this->deregisterCallback($cbName);
+    }
+};
+
 # Splits full callback name into namespace and short name.
 sub _splitCBName {
     my $this = shift;
@@ -168,17 +182,58 @@ sub registerCallback {
     my $this = shift;
     my ( $name, $fn, $userData ) = @_;
 
-    ASSERT( ref($fn) eq 'CODE', "callback must be a coderef" );
+    ASSERT( ref($fn) eq 'CODE',
+        "callback must be a coderef in a call to registerCallback method" );
 
     $name = $this->_guessCallbackName($name);
 
     ASSERT( $_registeredCBNames{$name}, "unknown callback '$name'" );
 
-    push @{ $this->_getApp->heap->{_aux_registered_callbacks}{$name} },
-      {
+    my $cbInfo = {
         code => $fn,
         data => $userData,
-      };
+        obj  => $this->__id,
+    };
+
+    push @{ $this->_getApp->heap->{_aux_registered_callbacks}{$name} }, $cbInfo;
+}
+
+=begin TML
+
+---+++ ObjectMethod deregisterCallback( $name [, $fn] )
+
+Deregisters callbacks registered by the object and defined by =$name=. If =$fn=
+is not defined then all registrations for callback =$name= are dropped.
+Otherwise it's only those pointing at coderef in =$fn= are affected. 
+
+=cut
+
+sub deregisterCallback {
+    my $this = shift;
+    my ( $name, $fn ) = @_;
+
+    ASSERT( ref($fn) eq 'CODE',
+        "callback must be a coderef in a call to deregisterCallback method" )
+      if defined $fn;
+
+    $name = $this->_guessCallbackName($name);
+
+    ASSERT( $_registeredCBNames{$name}, "unknown callback '$name'" );
+
+    my $objId   = $this->__id;
+    my $appHeap = $this->_getApp->heap;
+    my $oldList = $appHeap->{_aux_registered_callbacks}{$name};
+    my $newList = [];
+
+    #$this->_traceMsg("Deregistering callback `$name' for object $objId");
+
+    foreach my $cbInfo (@$oldList) {
+        push @$newList, $cbInfo
+          unless ( $cbInfo->{obj} eq $objId )
+          && ( !defined($fn) || $cbInfo->{code} == $fn );
+    }
+
+    $appHeap->{_aux_registered_callbacks}{$name} = $newList;
 }
 
 =begin TML