r71219 - in /branches/upstream/libobject-event-perl/current: Changes MANIFEST META.json META.yml README lib/Object/Event.pm t/06_unreg_guard.t t/13_methods.t t/18_method_inherit_2.t
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Sat Mar 12 01:07:39 UTC 2011
Author: jawnsy-guest
Date: Sat Mar 12 01:07:32 2011
New Revision: 71219
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=71219
Log:
[svn-upgrade] new version libobject-event-perl (1.220)
Added:
branches/upstream/libobject-event-perl/current/META.json
branches/upstream/libobject-event-perl/current/t/18_method_inherit_2.t
Modified:
branches/upstream/libobject-event-perl/current/Changes
branches/upstream/libobject-event-perl/current/MANIFEST
branches/upstream/libobject-event-perl/current/META.yml
branches/upstream/libobject-event-perl/current/README
branches/upstream/libobject-event-perl/current/lib/Object/Event.pm
branches/upstream/libobject-event-perl/current/t/06_unreg_guard.t
branches/upstream/libobject-event-perl/current/t/13_methods.t
Modified: branches/upstream/libobject-event-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libobject-event-perl/current/Changes?rev=71219&op=diff
==============================================================================
--- branches/upstream/libobject-event-perl/current/Changes (original)
+++ branches/upstream/libobject-event-perl/current/Changes Sat Mar 12 01:07:32 2011
@@ -1,4 +1,8 @@
Revision history for Object-Event:
+
+1.22 Thu Mar 10 17:17:58 CET 2011
+ - fixed a bug where event methods were not registered correctly.
+ - found a bug with using the guard to track cb registrations.
1.21 Thu Nov 5 19:37:58 CET 2009
- fixed a bug in the legacy forward code to support the old
Modified: branches/upstream/libobject-event-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libobject-event-perl/current/MANIFEST?rev=71219&op=diff
==============================================================================
--- branches/upstream/libobject-event-perl/current/MANIFEST (original)
+++ branches/upstream/libobject-event-perl/current/MANIFEST Sat Mar 12 01:07:32 2011
@@ -20,9 +20,11 @@
t/16_event.t
t/17_methods_alias.t
t/18_method_inherit.t
+t/18_method_inherit_2.t
t/19_method_exept.t
t/20_forward_legacy.t
samples/simple_example
samples/benchmark
samples/mass_example
META.yml Module meta-data (added by MakeMaker)
+META.json Module meta-data (added by MakeMaker)
Added: branches/upstream/libobject-event-perl/current/META.json
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libobject-event-perl/current/META.json?rev=71219&op=file
==============================================================================
--- branches/upstream/libobject-event-perl/current/META.json (added)
+++ branches/upstream/libobject-event-perl/current/META.json Sat Mar 12 01:07:32 2011
@@ -1,0 +1,1 @@
+{"no_index":{"directory":["t","inc"]},"meta-spec":{"version":1.4,"url":"http://module-build.sourceforge.net/META-spec-v1.4.html"},"generated_by":"ExtUtils::MakeMaker version 6.56","distribution_type":"module","version":"1.22","name":"Object-Event","author":["Robin Redeker <elmex at x-paste.de>"],"license":"perl","build_requires":{"ExtUtils::MakeMaker":0},"requires":{"Test::More":0,"AnyEvent":3.5,"common::sense":0},"abstract":"A class that provides an event callback interface","configure_requires":{"ExtUtils::MakeMaker":0}}
Modified: branches/upstream/libobject-event-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libobject-event-perl/current/META.yml?rev=71219&op=diff
==============================================================================
--- branches/upstream/libobject-event-perl/current/META.yml (original)
+++ branches/upstream/libobject-event-perl/current/META.yml Sat Mar 12 01:07:32 2011
@@ -1,24 +1,32 @@
---- #YAML:1.0
-name: Object-Event
-version: 1.21
-abstract: A class that provides an event callback interface
-author:
- - Robin Redeker <elmex at x-paste.de>
-license: perl
-distribution_type: module
-configure_requires:
- ExtUtils::MakeMaker: 0
-build_requires:
- ExtUtils::MakeMaker: 0
-requires:
- AnyEvent: 3.5
- common::sense: 0
- Test::More: 0
-no_index:
- directory:
- - t
- - inc
-generated_by: ExtUtils::MakeMaker version 6.55_02
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
+{
+ "no_index" : {
+ "directory" : [
+ "t",
+ "inc"
+ ]
+ },
+ "meta-spec" : {
+ "version" : 1.4,
+ "url" : "http://module-build.sourceforge.net/META-spec-v1.4.html"
+ },
+ "generated_by" : "ExtUtils::MakeMaker version 6.56",
+ "distribution_type" : "module",
+ "version" : "1.22",
+ "name" : "Object-Event",
+ "author" : [
+ "Robin Redeker <elmex at x-paste.de>"
+ ],
+ "license" : "perl",
+ "build_requires" : {
+ "ExtUtils::MakeMaker" : 0
+ },
+ "requires" : {
+ "Test::More" : 0,
+ "AnyEvent" : 3.5,
+ "common::sense" : 0
+ },
+ "abstract" : "A class that provides an event callback interface",
+ "configure_requires" : {
+ "ExtUtils::MakeMaker" : 0
+ }
+}
Modified: branches/upstream/libobject-event-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libobject-event-perl/current/README?rev=71219&op=diff
==============================================================================
--- branches/upstream/libobject-event-perl/current/README (original)
+++ branches/upstream/libobject-event-perl/current/README Sat Mar 12 01:07:32 2011
@@ -2,7 +2,7 @@
Object::Event - A class that provides an event callback interface
VERSION
- Version 1.21
+ Version 1.22
SYNOPSIS
package foo;
Modified: branches/upstream/libobject-event-perl/current/lib/Object/Event.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libobject-event-perl/current/lib/Object/Event.pm?rev=71219&op=diff
==============================================================================
--- branches/upstream/libobject-event-perl/current/lib/Object/Event.pm (original)
+++ branches/upstream/libobject-event-perl/current/lib/Object/Event.pm Sat Mar 12 01:07:32 2011
@@ -13,11 +13,11 @@
=head1 VERSION
-Version 1.21
-
-=cut
-
-our $VERSION = '1.21';
+Version 1.22
+
+=cut
+
+our $VERSION = '1.22';
=head1 SYNOPSIS
@@ -146,6 +146,8 @@
_init_methods ($pkg) unless *{"$pkg\::__OE_METHODS"}{HASH};
+ $self->{__oe_cb_gen} = "a"; # generation counter
+
$self->{__oe_events} = {
map {
($_ => [@{${"$pkg\::__OE_METHODS"}{$_}}])
@@ -256,7 +258,7 @@
}
sub _register_event_struct {
- my ($self, $event, $prio, $callback, $debug) = @_;
+ my ($self, $event, $prio, $gen, $callback, $debug) = @_;
my $reg = ($self->{__oe_events} ||= {});
my $idx = 0;
@@ -271,7 +273,7 @@
my $cb = $callback;
$cb = _debug_cb ($callback) if $DEBUG > 1;
- splice @$evlist, $idx, 0, [$prio, "$callback", undef, $debug, $cb];
+ splice @$evlist, $idx, 0, [$prio, "$callback|$gen", undef, $debug, $cb];
}
sub reg_cb {
@@ -286,6 +288,8 @@
$debuginfo = sprintf "%s:%d (%s::)", $file, $line, $pkg;
}
+ my $gen = $self->{__oe_cb_gen}++; # get gen counter
+
my @cbs;
while (@args) {
my ($ev, $sec) = (shift @args, shift @args);
@@ -307,12 +311,12 @@
$cb = shift @args;
}
- $self->_register_event_struct ($ev, $prio, $cb, $debuginfo);
+ $self->_register_event_struct ($ev, $prio, $gen, $cb, $debuginfo);
push @cbs, $cb;
}
defined wantarray
- ? \(my $g = guard { if ($self) { $self->unreg_cb ($_) for @cbs } })
+ ? \(my $g = guard { if ($self) { $self->unreg_cb ($_, $gen) for @cbs } })
: ()
}
@@ -323,7 +327,7 @@
=cut
sub unreg_cb {
- my ($self, $cb) = @_;
+ my ($self, $cb, $gen) = @_;
if (ref ($cb) eq 'REF') {
# we've got a guard object
@@ -333,8 +337,18 @@
my $evs = $self->{__oe_events};
+ # $gen is neccessary for the times where we use the guard to remove
+ # something, because we only have the callback as ID we need to track the
+ # generation of the registration for these:
+ #
+ # my $cb = sub { ... };
+ # my $g = $o->reg_cb (a => $cb);
+ # $g = $o->reg_cb (a => $cb);
+ my ($key, $key_len) = defined $gen
+ ? ("$cb|$gen", length "$cb|$gen")
+ : ("$cb", length "$cb");
for my $reg (values %$evs) {
- @$reg = grep { $_->[1] ne $cb } @$reg;
+ @$reg = grep { (substr $_->[1], 0, $key_len) ne $key } @$reg;
}
}
@@ -742,26 +756,29 @@
sub _init_methods {
my ($pkg) = @_;
- my $sup = \%{"$pkg\::__OE_METHODS"};
-
- for my $superpkg (@{"$pkg\::ISA"}) {
- next unless $superpkg->isa ("Object::Event");
-
+ my $pkg_meth = \%{"$pkg\::__OE_METHODS"};
+
+ for my $superpkg (@{"$pkg\::ISA"}) { # go recursively into super classes
+ next unless $superpkg->isa ("Object::Event"); # skip non O::E
+
+ # go into the class if we have not already been there
_init_methods ($superpkg)
unless *{"$superpkg\::__OE_METHODS"}{HASH};
+ # add the methods of the $superpkg to our own
for (keys %{"$superpkg\::__OE_METHODS"}) {
- push @{$sup->{$_}}, @{${"$superpkg\::__OE_METHODS"}{$_} || []};
+ push @{$pkg_meth->{$_}}, @{${"$superpkg\::__OE_METHODS"}{$_} || []};
}
}
my %mymethds;
+ # now check each package symbol
for my $realmeth (keys %{"$pkg\::"}) {
my $coderef = *{"$pkg\::$realmeth"}{CODE};
- next unless exists $ATTRIBUTES{$pkg}->{"$coderef"};
- my $m = $ATTRIBUTES{$pkg}->{"$coderef"};
+ next unless exists $ATTRIBUTES{$pkg}->{"$coderef"}; # skip unattributed methods
+ my $m = $ATTRIBUTES{$pkg}->{"$coderef"}; # $m = [$prio, $event_name]
my $meth = $realmeth;
@@ -776,30 +793,37 @@
(exists $PRIO_MAP{$m->[0]} # set priority
? $PRIO_MAP{$m->[0]}
: 0+$m->[0]),
- "$coderef",
- $realmeth,
- $pkg . '::' . $realmeth,
- $cb
- ] if defined &{"$pkg\::$meth"};
-
- #d# warn "REPLACED $pkg $meth => $coderef ($m->[1])\n";
+ "$coderef", # callback id
+ $realmeth, # original method name
+ $pkg . '::' . $realmeth, # debug info
+ $cb # the callback
+
+ # only replace if defined, otherwise declarations without definitions will
+ # replace the $cb/$coderef with something that calls itself recursively.
+
+ ] if defined &{"$pkg\::$realmeth"};
+
+ #d# warn "REPLACED $pkg $meth (by $realmeth) => $coderef ($m->[1])\n";
_replace_method ($pkg, $realmeth, $meth);
}
+ # sort my methods by name
for my $ev (keys %mymethds) {
@{$mymethds{$ev}} =
sort { $a->[2] cmp $b->[2] }
@{$mymethds{$ev}};
}
- push @{$sup->{$_}}, @{$mymethds{$_}}
+ # add my methods to the super class method list
+ push @{$pkg_meth->{$_}}, @{$mymethds{$_}}
for keys %mymethds;
- for my $ev (keys %$sup) {
- @{$sup->{$ev}} =
+ # sort by priority over all, stable to not confuse names
+ for my $ev (keys %$pkg_meth) {
+ @{$pkg_meth->{$ev}} =
sort { $b->[0] <=> $a->[0] }
- @{$sup->{$ev}};
+ @{$pkg_meth->{$ev}};
}
}
Modified: branches/upstream/libobject-event-perl/current/t/06_unreg_guard.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libobject-event-perl/current/t/06_unreg_guard.t?rev=71219&op=diff
==============================================================================
--- branches/upstream/libobject-event-perl/current/t/06_unreg_guard.t (original)
+++ branches/upstream/libobject-event-perl/current/t/06_unreg_guard.t Sat Mar 12 01:07:32 2011
@@ -1,6 +1,6 @@
#!perl
-use Test::More tests => 4;
+use Test::More tests => 5;
package foo;
use common::sense;
@@ -31,3 +31,11 @@
is ($called, 10, "second test still called once");
ok (!$f->handles ('test'), "no handler anymore");
+
+$called = 0;
+my $sub = sub { $called++ };
+$id = $f->reg_cb (t => $sub);
+$f->event ('t');
+$id = $f->reg_cb (t => $sub);
+$f->event ('t');
+is ($called, 2, "guard removal on assignment correct");
Modified: branches/upstream/libobject-event-perl/current/t/13_methods.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libobject-event-perl/current/t/13_methods.t?rev=71219&op=diff
==============================================================================
--- branches/upstream/libobject-event-perl/current/t/13_methods.t (original)
+++ branches/upstream/libobject-event-perl/current/t/13_methods.t Sat Mar 12 01:07:32 2011
@@ -1,6 +1,6 @@
#!perl
-use Test::More tests => 11;
+use Test::More tests => 12;
package foo;
use common::sense;
@@ -19,6 +19,8 @@
sub pt : event_cb { push @{$_[0]->{a}}, 20 }
sub foobar : event_cb;
+
+sub foozzz : event_cb(, foobar);
package foo2;
use base qw/foo/;
@@ -53,6 +55,10 @@
is ($f->{b}, 10, 'first object got method with event callback');
is ($f2->{b}, undef, 'second object doesn\'t have method with event callback');
+$f->{b} = 0;
+$f->foozzz;
+is ($f->{b}, 10, 'first object got method with event callback with alias method');
+
ok ($f->event ('test'), 'event returns true for methods');
my $g = foo3->new;
Added: branches/upstream/libobject-event-perl/current/t/18_method_inherit_2.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libobject-event-perl/current/t/18_method_inherit_2.t?rev=71219&op=file
==============================================================================
--- branches/upstream/libobject-event-perl/current/t/18_method_inherit_2.t (added)
+++ branches/upstream/libobject-event-perl/current/t/18_method_inherit_2.t Sat Mar 12 01:07:32 2011
@@ -1,0 +1,55 @@
+#!perl
+
+use Test::More tests => 3;
+
+package moh;
+use common::sense;
+use base qw/Object::Event/;
+
+sub xtest : event_cb(,test) {
+ push @{$_[0]->{x}}, 'moh2'
+}
+
+sub ztest : event_cb(-10,test) {
+ push @{$_[0]->{x}}, 'moh3'
+}
+
+package baz;
+use common::sense;
+use base qw/moh/;
+
+sub xtest : event_cb(-100,test) {
+ push @{$_[0]->{x}}, 'baz2'
+}
+
+sub mtest : event_cb(-1000,test) {
+ push @{$_[0]->{x}}, 'bazlast'
+}
+
+package meh;
+use common::sense;
+use base qw/baz/;
+
+sub test : event_cb {
+ push @{$_[0]->{x}}, 'meh'
+}
+
+package main;
+use common::sense;
+
+my $f = baz->new;
+
+$f->reg_cb (test => 100 => sub { push @{$_[0]->{x}}, 'first' });
+$f->event ('test');
+is (join (',', @{$f->{x}}), 'first,moh2,moh3,baz2,bazlast', 'foo class');
+
+my $m = meh->new;
+$m->reg_cb (test => -1 => sub { push @{$_[0]->{x}}, 'middle2' });
+$m->test;
+is (join (',', @{$m->{x}}),
+ 'moh2,meh,middle2,moh3,baz2,bazlast',
+ 'meh class diamond');
+
+my $b = baz->new;
+$b->event ('test');
+is (join (',', @{$b->{x}}), 'moh2,moh3,baz2,bazlast', 'baz class');
More information about the Pkg-perl-cvs-commits
mailing list