Item14237: Merge commit 'e9ecff39ef17db4b279d411283c7508f06e7623b' in…

…to Item14237

* commit 'e9ecff39ef17db4b279d411283c7508f06e7623b':
  Item14152: Fixed a problem with applying roles
  Item14152: Forgotten MANIFEST
  Item13897: Don't generate extra stack trace on fata exceptions

UnitTestContrib/lib/Foswiki/Contrib/UnitTestContrib/MANIFEST

@@ -29,6 +29,7 @@ test/unit/AddressTests.pm 0644
 test/unit/AdminOnlyAccessControlTests.pm 0644
 test/unit/AttrsTests.pm 0644
 test/unit/CacheTests.pm 0644
+test/unit/CallbackTests.pm 0644
 test/unit/ClientTests.pm 0644
 test/unit/ConfigTests.pm 0644
 test/unit/ConfigureQueryTests.pm 0644

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

core/lib/Foswiki/Class.pm

@@ -228,7 +228,7 @@ sub _fw_has {
     my $target = shift;
     my ($attr) = @_;
 
-    #say STDERR "Registering attr $attr on $target";
+    #say STDERR "Registering attr `$attr' on $target";
 
     push @{ $_classData{$target}{registeredAttrs}{list} },
       { attr => $attr, options => [ @_[ 1 .. $#_ ] ] };
@@ -259,14 +259,16 @@ sub _fw_extends {
 
         # Install BUILD method if a feature requiring it requested.
         # Otherwise feature implementation role will fail to apply cleanly.
-        unless ( defined $trg_ns->{BUILD}
-            && defined *{ $trg_ns->{BUILD} }{CODE} )
-        {
-            #say STDERR "Installing BUILD for $target";
-            install_modifier( $target, fresh => BUILD => sub { } );
-        }
+        #unless ( defined $trg_ns->{BUILD}
+        #    && defined *{ $trg_ns->{BUILD} }{CODE} )
+        #{
+        #    #say STDERR "Installing BUILD for $target";
+        #    install_modifier( $target, fresh => BUILD => sub { } );
+        #}
     }
-    __PACKAGE__->_apply_roles;
+
+    #say STDERR "Applying roles to $target";
+    __PACKAGE__->_apply_roles($target);
 }
 
 if ( $ENV{FOSWIKI_ASSERTS} ) {
@@ -306,8 +308,12 @@ foreach my $module (qw(Moo Moo::Role)) {
                 #say STDERR "Installing wrapper $codeName on $target";
                 my $origCode = $_[2];
                 $_[2] = sub {
+
+                    #say STDERR "Orig ${target}::$codeName code first.";
+                    &$origCode(@_);
+
+                    #say STDERR "Extension ${target}::$codeName code next.";
                     $ovCode->( $target, @_ );
-                    goto &$origCode;
                 };
             }
             goto &$_install_tracked;
@@ -327,7 +333,7 @@ sub import {
     my ($class) = shift;
     my $target = caller;
 
-    #say STDERR "Foswiki::Class($class, $target)";
+    #say STDERR "--- Foswiki::Class($class, $target)";
 
     local $SIG{__DIE__} = sub { Carp::confess(@_) }
       if $ENV{FOSWIKI_ASSERTS};
@@ -467,21 +473,24 @@ sub _inject_code {
 
 =begin TML
 
----+++ StaticMethod _apply_roles( $class )
+---+++ StaticMethod _apply_roles( $class [, @classes] )
 
 %X% Strictly for internal =Foswiki::Class= use only.
 
-This method applies previosly assigned roles to a =$class=.
+This method applies previosly assigned roles to a =$class=. If =@classes= is
+non-zero length then roles are applied to the specified classes only. Otherwise
+all assigned classes are processed.
 
 =cut
 
 sub _apply_roles {
     my $class = shift;
-    foreach my $target (
-        grep { defined $_classData{$_}{assignedRoles} }
-        keys %_classData
-      )
-    {
+
+    my @targets =
+      grep { defined $_classData{$_}{assignedRoles} }
+      ( scalar(@_) ? @_ : keys %_classData );
+
+    foreach my $target (@targets) {
 
        #say STDERR "Applying roles ",
        #  join( ", ", @{ $_classData{$target}{assignedRoles} } ), " to $target";