r4910 - in /packages/libset-object-perl/branches/upstream/current:
./ lib/Set/ lib/Set/Object/ t/ingy/ t/misc/ t/object/ t/scalar/
gwolf at users.alioth.debian.org
gwolf at users.alioth.debian.org
Thu Mar 1 00:26:01 CET 2007
Author: gwolf
Date: Thu Mar 1 00:26:01 2007
New Revision: 4910
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=4910
Log:
[svn-upgrade] Integrating new upstream version, libset-object-perl (1.21)
Added:
packages/libset-object-perl/branches/upstream/current/lib/Set/Object/
packages/libset-object-perl/branches/upstream/current/lib/Set/Object/Weak.pm
packages/libset-object-perl/branches/upstream/current/t/misc/
packages/libset-object-perl/branches/upstream/current/t/misc/leaks.t
packages/libset-object-perl/branches/upstream/current/t/misc/pod.t
packages/libset-object-perl/branches/upstream/current/t/misc/pod_coverage.t
packages/libset-object-perl/branches/upstream/current/t/object/weakref.t
Modified:
packages/libset-object-perl/branches/upstream/current/Changes.pod
packages/libset-object-perl/branches/upstream/current/MANIFEST
packages/libset-object-perl/branches/upstream/current/META.yml
packages/libset-object-perl/branches/upstream/current/Makefile.PL
packages/libset-object-perl/branches/upstream/current/Object.xs
packages/libset-object-perl/branches/upstream/current/README
packages/libset-object-perl/branches/upstream/current/lib/Set/Object.pm
packages/libset-object-perl/branches/upstream/current/t/ingy/arrayref.t
packages/libset-object-perl/branches/upstream/current/t/scalar/compare.t
Modified: packages/libset-object-perl/branches/upstream/current/Changes.pod
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/Changes.pod?rev=4910&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/Changes.pod (original)
+++ packages/libset-object-perl/branches/upstream/current/Changes.pod Thu Mar 1 00:26:01 2007
@@ -1,5 +1,57 @@
=head1 REVISION HISTORY FOR Set::Object
+
+=head1 1.21, 17 Feb 2007
+
+=over
+
+=item *
+
+Fix false negative when Test::Pod::Coverage isn't installed. Reported
+by Anna Bernathova of SuSE.
+
+=back
+
+=head1 1.20, 16 Feb 2007
+
+=over
+
+=item *
+
+The C<-E<gt>compare> function was returning "disjoint" for empty sets.
+RT#24965. (Nigel Metheringham)
+
+=item *
+
+Document lots of methods that were previously not documented.
+
+=item *
+
+Fix C<Set::Object::Weak::set()>. It was not passing its arguments to
+C<Set::Object::Weak-E<gt>new()>, which was very broken.
+
+=back
+
+=head1 1.19, 23 Jan 2007
+
+=over
+
+=item *
+
+remove bogus inclusions of Data::Dumper and Devel::Peek
+
+=item *
+
+New class C<Set::Object::Weak>, which all weak sets should get
+re-blessed into when you call C<-E<gt>weaken>. Also added alternative
+methods of constructing weak sets.
+
+=item *
+
+Fix a memory leak with scalar members (the internal hash used to store
+the items was never being freed). RT#24508.
+
+=back
=head1 1.18, 14 Sep 2006
Modified: packages/libset-object-perl/branches/upstream/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/MANIFEST?rev=4910&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/MANIFEST (original)
+++ packages/libset-object-perl/branches/upstream/current/MANIFEST Thu Mar 1 00:26:01 2007
@@ -4,6 +4,7 @@
README
META.yml Module meta-data (added by MakeMaker)
lib/Set/Object.pm
+lib/Set/Object/Weak.pm
Object.xs
t/object/equal.t
t/object/clear.t
@@ -23,6 +24,7 @@
t/object/abuse.t
t/object/properties.t
t/object/storable.t
+t/object/weakref.t
t/scalar/basic_overload.t
t/scalar/basic.t
@@ -44,4 +46,8 @@
t/ingy/arrayref.t
+t/misc/leaks.t
+t/misc/pod.t
+t/misc/pod_coverage.t
+
ppport.h
Modified: packages/libset-object-perl/branches/upstream/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/META.yml?rev=4910&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/META.yml (original)
+++ packages/libset-object-perl/branches/upstream/current/META.yml Thu Mar 1 00:26:01 2007
@@ -1,7 +1,7 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: Set-Object
-version: 1.18
+version: 1.21
version_from: lib/Set/Object.pm
installdirs: site
requires:
Modified: packages/libset-object-perl/branches/upstream/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/Makefile.PL?rev=4910&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/Makefile.PL (original)
+++ packages/libset-object-perl/branches/upstream/current/Makefile.PL Thu Mar 1 00:26:01 2007
@@ -8,6 +8,8 @@
'LIBS' => [''], # e.g., '-lm'
'DEFINE' => '', # e.g., '-DHAVE_SOMETHING'
'INC' => '', # e.g., '-I/usr/include/other'
- PM => {'lib/Set/Object.pm' => '$(INST_LIBDIR)/Object.pm'},
- test => { TESTS => join(' ', glob('t/object/*.t'), glob('t/scalar/*.t')) },
+ PM => {'lib/Set/Object.pm' => '$(INST_LIBDIR)/Object.pm',
+ 'lib/Set/Object/Weak.pm' => '$(INST_LIBDIR)/Object/Weak.pm',
+ },
+ test => { TESTS => join(' ', glob('t/*/*.t')) },
);
Modified: packages/libset-object-perl/branches/upstream/current/Object.xs
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/Object.xs?rev=4910&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/Object.xs (original)
+++ packages/libset-object-perl/branches/upstream/current/Object.xs Thu Mar 1 00:26:01 2007
@@ -818,6 +818,7 @@
iset_clear(s);
if (s->flat) {
hv_undef(s->flat);
+ SvREFCNT_dec(s->flat);
}
Safefree(s);
@@ -833,7 +834,7 @@
OUTPUT: RETVAL
void
-weaken(self)
+_weaken(self)
SV* self
CODE:
@@ -849,7 +850,7 @@
_fiddle_strength(s, 0);
void
-strengthen(self)
+_strengthen(self)
SV* self
CODE:
@@ -931,6 +932,20 @@
magic = newRV_inc(mg->mg_obj);
PUSHs(magic);
XSRETURN(1);
+
+SV*
+get_flat(sv)
+ SV* sv
+PROTOTYPE: $
+CODE:
+ ISET* s = INT2PTR(ISET*, SvIV(SvRV(sv)));
+ if (s->flat) {
+ RETVAL = newRV_inc(s->flat);
+ } else {
+ XSRETURN_UNDEF;
+ }
+OUTPUT:
+ RETVAL
char *
blessed(sv)
Modified: packages/libset-object-perl/branches/upstream/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/README?rev=4910&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/README (original)
+++ packages/libset-object-perl/branches/upstream/current/README Thu Mar 1 00:26:01 2007
@@ -1,4 +1,4 @@
-README for Set::Object 1.18
+README for Set::Object 1.21
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set::Object provides for sets of Perl objects - scalars and references.
Modified: packages/libset-object-perl/branches/upstream/current/lib/Set/Object.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/lib/Set/Object.pm?rev=4910&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/lib/Set/Object.pm (original)
+++ packages/libset-object-perl/branches/upstream/current/lib/Set/Object.pm Thu Mar 1 00:26:01 2007
@@ -67,11 +67,21 @@
into strings, so will lose any magic (eg, tie) or other special bits
that they went in with; only strings come out.
-=head1 CLASS METHODS
-
-=head2 new( [I<list>] )
+=head1 CONSTRUCTORS
+
+=head2 Set::Object->new( [I<list>] )
Return a new C<Set::Object> containing the elements passed in I<list>.
+
+=head2 C<set(@members)>
+
+Return a new C<Set::Object> filled with C<@members>. You have to
+explicitly import this method.
+
+=head2 C<weak_set()>
+
+Return a new C<Set::Object::Weak>, filled with C<@members>. You have
+to explicitly import this method.
=head1 INSTANCE METHODS
@@ -134,9 +144,26 @@
C<weaken>, please reduce your problem to a test script before
submission.
+B<New:> as of Set::Object 1.19, you may use the C<weak_set> function
+to make weak sets, or C<Set::Object::Weak-E<gt>new>, or import the
+C<set> constructor from C<Set::Object::Weak> instead. See
+L<Set::Object::Weak> for more.
+
+B<Note to people sub-classing C<Set::Object>:> this method re-blesses
+the invocant to C<Set::Object::Weak>. Override the method C<weak_pkg>
+in your sub-class to control this behaviour.
+
+=head2 is_weak
+
+Returns a true value if this set is a weak set.
+
=head2 strengthen
Turns a weak set back into a normal one.
+
+B<Note to people sub-classing C<Set::Object>:> this method re-blesses
+the invocant to C<Set::Object>. Override the method C<strong_pkg> in
+your sub-class to control this behaviour.
=head2 invert( [I<list>] )
@@ -156,6 +183,20 @@
Return a textual Smalltalk-ish representation of the C<Set::Object>.
Also available as overloaded operator "".
+=head2 equal( I<set> )
+
+Returns a true value if I<set> contains exactly the same members as
+the invocant.
+
+Also available as overloaded operator C<==> (or C<eq>).
+
+=head2 not_equal( I<set> )
+
+Returns a false value if I<set> contains exactly the same members as
+the invocant.
+
+Also available as overloaded operator C<!=> (or C<ne>).
+
=head2 intersection( [I<list>] )
Return a new C<Set::Object> containing the intersection of the
@@ -207,6 +248,11 @@
Return C<true> if this C<Set::Object> is a proper superset of I<set>
Also available as operator C<E<gt>>.
+
+=head2 is_null( I<set> )
+
+Returns a true value if this set does not contain any members, that
+is, if its size is zero.
=head1 Set::Scalar compatibility methods
@@ -306,6 +352,34 @@
change the array :). This is used only by the test suite, and if you
find it useful for something then you should probably conjure up a
test suite and send it to me, otherwise it could get pulled.
+
+=back
+
+=head1 CLASS METHODS
+
+These class methods are probably only interesting to those
+sub-classing C<Set::Object>.
+
+=over
+
+=item strong_pkg
+
+When a set that was already weak is strengthened using
+C<-E<gt>strengthen>, it gets re-blessed into this package.
+
+=item weak_pkg
+
+When a set that was NOT already weak is weakened using
+C<-E<gt>weaken>, it gets re-blessed into this package.
+
+=item tie_array_pkg
+
+When the object is accessed as an array, tie the array into this
+package.
+
+=item tie_hash_pkg
+
+When the object is accessed as a hash, tie the hash into this package.
=back
@@ -390,7 +464,8 @@
Portions Copyright (c) 2003 - 2005, Sam Vilain. Same license.
-Portions Copyright (c) 2006, Catalyst IT (NZ) Limited. Same license.
+Portions Copyright (c) 2006, 2007, Catalyst IT (NZ) Limited. Same
+license.
=head1 SEE ALSO
@@ -414,8 +489,8 @@
# Do not simply export all your public functions/methods/constants.
@EXPORT_OK = qw( ish_int is_int is_string is_double blessed reftype
- refaddr is_overloaded is_object is_key set );
-$VERSION = '1.18';
+ refaddr is_overloaded is_object is_key set weak_set );
+$VERSION = '1.21';
bootstrap Set::Object $VERSION;
@@ -860,7 +935,7 @@
return ("v3-" . ($obj->is_weak ? "w" : "s"), [ $obj->members ]);
}
-use Devel::Peek qw(Dump);
+#use Devel::Peek qw(Dump);
sub STORABLE_thaw {
#print Dump $_ foreach (@_);
@@ -935,7 +1010,12 @@
}
}
} else {
- return "disjoint";
+ if ($self->size || $other->size) {
+ return "disjoint";
+ } else {
+ # both sets are empty
+ return "equal";
+ }
}
}
@@ -947,7 +1027,7 @@
return !($self*$other)->size;
}
-use Data::Dumper;
+#use Data::Dumper;
sub as_string_callback {
shift;
if ( @_ ) {
@@ -979,6 +1059,32 @@
sub set {
__PACKAGE__->new(@_);
}
+sub weak_set {
+ my $self = __PACKAGE__->new();
+ $self->weaken;
+ $self->insert(@_);
+ return $self;
+}
+
+require Set::Object::Weak;
+sub weaken {
+ my $self = shift;
+ $self->_weaken;
+ bless $self, $self->weak_pkg;
+}
+
+sub strengthen {
+ my $self = shift;
+ $self->_strengthen;
+ bless $self, $self->strong_pkg;
+}
+
+sub weak_pkg {
+ "Set::Object::Weak";
+}
+sub strong_pkg {
+ "Set::Object";
+}
1;
__END__
Added: packages/libset-object-perl/branches/upstream/current/lib/Set/Object/Weak.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/lib/Set/Object/Weak.pm?rev=4910&op=file
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/lib/Set/Object/Weak.pm (added)
+++ packages/libset-object-perl/branches/upstream/current/lib/Set/Object/Weak.pm Thu Mar 1 00:26:01 2007
@@ -1,0 +1,99 @@
+
+=head1 NAME
+
+Set::Object::Weak - Sets without the referant reference increment
+
+=head1 SYNOPSIS
+
+ use Set::Object::Weak qw(weak_set);
+
+ my $set = Set::Object::Weak->new( 0, "", {}, [], $object );
+ # or
+ my $set = weak_set( 0, "", {}, [], $object );
+
+ print $set->size; # 2 - the scalars aren't objects
+
+=head1 DESCRIPTION
+
+Sets, but weak. See L<Set::Object/weaken>.
+
+Note that the C<set> in C<Set::Object::Weak> returns weak sets. This
+is intentional, so that you can make all the sets in scope weak just
+by changing C<use Set::Object> to C<use Set::Object::Weak>.
+
+=cut
+
+package Set::Object::Weak;
+
+use base qw(Set::Object); # boo hiss no moose::role yet I hear you say
+
+use base qw(Exporter); # my users would hate me otherwise
+use vars qw(@ISA @EXPORT_OK);
+
+our @EXPORT_OK = qw(weak_set set);
+
+=head1 CONSTRUCTORS
+
+=over
+
+=item new
+
+This class method is exactly the same as C<Set::Object-E<gt>new>,
+except that it returns a weak set.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new();
+ $self->weaken;
+ $self->insert(@_);
+ $self;
+}
+
+=item weak_set( ... )
+
+This optionally exported B<function> is a shortcut for saying
+C<Set::Object::Weak-E<gt>new(...)>.
+
+=cut
+
+
+sub weak_set {
+ __PACKAGE__->new(@_);
+}
+
+=item set( ... )
+
+This method is exported so that if you see:
+
+ use Set::Object qw(set);
+
+You can turn it into using weak sets lexically with:
+
+ use Set::Object::Weak qw(set);
+
+Set::Object 1.19 had a bug in this method that meant that it would not
+add the passed members into it.
+
+=cut
+
+sub set {
+ __PACKAGE__->new(@_);
+}
+
+1;
+
+__END__
+
+=back
+
+=head1 SEE ALSO
+
+L<Set::Object>
+
+=head1 CREDITS
+
+Perl magic by Sam Vilain, <samv at cpan.org>
+
+Idea from nothingmuch.
Modified: packages/libset-object-perl/branches/upstream/current/t/ingy/arrayref.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/t/ingy/arrayref.t?rev=4910&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/t/ingy/arrayref.t (original)
+++ packages/libset-object-perl/branches/upstream/current/t/ingy/arrayref.t Thu Mar 1 00:26:01 2007
@@ -1,6 +1,6 @@
# -*- perl -*-
-use Set::Object;
+use Set::Object qw(set);
use Test::More tests => 15;
my $bob = bless {}, "Bob";
Added: packages/libset-object-perl/branches/upstream/current/t/misc/leaks.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/t/misc/leaks.t?rev=4910&op=file
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/t/misc/leaks.t (added)
+++ packages/libset-object-perl/branches/upstream/current/t/misc/leaks.t Thu Mar 1 00:26:01 2007
@@ -1,0 +1,37 @@
+#!/usr/bin/perl -w
+
+use Test::More tests => 9;
+
+BEGIN{ use_ok Set::Object;
+ Set::Object->import("set");
+ }
+
+use strict;
+use Scalar::Util qw(weaken);
+
+# first, a series of sanity checks...
+my $internal;
+{
+ my $set = set();
+ is($internal, undef, "no flat yet");
+
+ $set->insert({ "hi" => "there" });
+ $internal = $set->get_flat;
+ is($internal, undef, "still no flat");
+
+ $set->insert(1, 2, 3, 4);
+ $internal = $set->get_flat;
+ isnt($internal, undef, "aha, got something now");
+ ok(exists($internal->{2}), "and it looks like the right one");
+
+ weaken($internal);
+ ok($internal, "didn't drop out of existence on weaken()");
+
+ ok(!exists($internal->{5}), "sanity check");
+ $set->insert(5);
+ ok(exists($internal->{5}), "we've really got the right hash");
+}
+
+# when the set drops out of existence, the hashref should too
+is($internal, undef, "internal hashref drops out of existence");
+
Added: packages/libset-object-perl/branches/upstream/current/t/misc/pod.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/t/misc/pod.t?rev=4910&op=file
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/t/misc/pod.t (added)
+++ packages/libset-object-perl/branches/upstream/current/t/misc/pod.t Thu Mar 1 00:26:01 2007
@@ -1,0 +1,6 @@
+#!perl
+
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
Added: packages/libset-object-perl/branches/upstream/current/t/misc/pod_coverage.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/t/misc/pod_coverage.t?rev=4910&op=file
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/t/misc/pod_coverage.t (added)
+++ packages/libset-object-perl/branches/upstream/current/t/misc/pod_coverage.t Thu Mar 1 00:26:01 2007
@@ -1,0 +1,29 @@
+#!perl
+
+BEGIN {
+ eval "use Test::Pod::Coverage tests => 2;";
+ if ( $@ ) {
+ require Test::More;
+ Test::More::plan(skip_all => ("Test::Pod::Coverage required for "
+ ."testing POD coverage"));
+ exit;
+ }
+}
+
+use Set::Object;
+use Set::Object::Weak;
+
+pod_coverage_ok
+ ( "Set::Object",
+ { also_private => [ qr/^STORABLE_/, qr/^op_/,
+ "get_flat",
+ "rvrc", "rc", "is_object",
+ ], },
+ "Set::Object, except the functions we know are private",
+ );
+
+pod_coverage_ok
+ ( "Set::Object::Weak",
+ { also_private => [ qr/^[A-Z_]+$/ ], },
+ "Set::Object::Weak, with all-caps functions as privates",
+ );
Added: packages/libset-object-perl/branches/upstream/current/t/object/weakref.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/t/object/weakref.t?rev=4910&op=file
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/weakref.t (added)
+++ packages/libset-object-perl/branches/upstream/current/t/object/weakref.t Thu Mar 1 00:26:01 2007
@@ -1,0 +1,195 @@
+# -*- perl -*-
+
+use Test::More tests => 37;
+use Set::Object qw(set refaddr);
+use Storable qw(dclone);
+use strict;
+
+my $set = set();
+
+{ package MyClass;
+ our $c;
+ sub new { $c++; my $pkg = shift;
+ my $self = bless {@_}, $pkg;
+ #print STDERR "# NEW - $self\n";
+ $self;
+ }
+ sub DESTROY {
+ my $self = shift;
+ #print STDERR "# FREE - $self\n";
+ $c-- }
+}
+
+use Devel::Peek;
+
+{
+ my $item = MyClass->new;
+ $set->insert($item);
+ is($set->size, 1, "sanity check 1");
+ isa_ok($set, "Set::Object", "it's a Set::Object");
+ ok(!$set->isa("Set::Object::Weak"), "but not weak");
+ #diag(Dump($item));
+ $set->weaken;
+ #diag(Dump($item));
+ is($set->size, 1, "weaken not too eager");
+ isa_ok($set, "Set::Object::Weak", "it's now a Set::Object::Weak");
+}
+
+is($MyClass::c, 0, "weaken makes refcnt lower");
+is($set->size, 0, "Set knows that the object expired");
+diag($_) for $set->members;
+
+$set->insert(MyClass->new);
+is($set->size, 0, "weakened sets can't hold temporary objects");
+
+my $structure = MyClass->new
+ (
+ bob => [ "Hi, I'm bob" ],
+ who => set(),
+ );
+
+$structure->{who}->insert($structure->{bob});
+$structure->{who}->weaken;
+
+#diag("now cloning");
+
+my $clone = dclone $structure;
+
+isnt(refaddr($structure->{bob}), refaddr($clone->{bob}), "sanity check 2");
+isnt(${$structure->{who}}, ${$clone->{who}}, "sanity check 3");
+
+is($clone->{who}->size, 1, "Set has size");
+is(($clone->{who}->members)[0], $clone->{bob}, "Set contents preserved");
+
+delete $clone->{bob};
+
+is($clone->{who}->size, 0, "weaken preserved over dclone()");
+
+# test strengthen, too
+{
+ $set->clear();
+ $set->weaken();
+ my $ref = {};
+ {
+ my $ref2 = {};
+ $set->insert($ref, $ref2);
+ is($set->size, 2, "sanity check 4");
+ }
+ is($set->size, 1, "sanity check 5");
+ isa_ok($set, "Set::Object::Weak", "starts as a Set::Object::Weak");
+ $set->strengthen;
+}
+
+isa_ok($set, "Set::Object", "it's a Set::Object");
+ok(!$set->isa("Set::Object::Weak"), "but not weak");
+is($set->size, 1, "->strengthen()");
+
+# test that weak sets can expire before their referants
+{
+ my $referant = [ "hello, world" ];
+ {
+ my $set = set();
+ $set->weaken;
+ $set->insert($referant);
+ my $magic = Set::Object::get_magic($referant);
+ is_deeply($magic, [$$set], "Magic detected");
+ }
+ my $magic = Set::Object::get_magic($referant);
+ #diag("magic is $magic, length ".@$magic);
+ #Dump($magic);
+ #diag("got that? :)");
+ is_deeply($magic, undef, "Magic removed");
+}
+
+# test that dispel works with tied refs
+{
+ my %object;
+ tie %object, 'Tie::Scalar::Null' => \%object;
+
+ $object{x} = "Hello";
+ is($object{x}, "Hello, world", "sanity check 6");
+
+ {
+ my $set = set(\%object);
+ $object{x} = "I'd like to buy you a coke";
+ my ($member) = $set->members;
+ is($member->{x},
+ "I'd like to buy you a coke, world", "sanity check 7");
+ $set->weaken;
+ $object{x} = "You're the one";
+ is($object{x}, "You're the one, world",
+ "weak_set magic doesn't interfere with tie magic");
+ is_deeply(Set::Object::get_magic(\%object), [$$set], "Magic detected");
+ }
+ is($object{x}, "You're the one, world",
+ "hash not ruined by _dispel_magic");
+
+ is_deeply(Set::Object::get_magic(\%object), undef, "Magic removed");
+ $object{y} = "Catch the light";
+ is($object{y}, "Catch the light, world",
+ "tie magic not interefered with by _dispel_magic");
+}
+
+# now do it the other way around...
+{
+ my %object;
+
+ {
+ my $set = set(\%object);
+ $set->weaken;
+
+ tie %object, 'Tie::Scalar::Null' => \%object;
+
+ my ($member) = $set->members;
+ $member->{x} = "I'm almost over XS for one day";
+ is($member->{x},
+ "I'm almost over XS for one day, world", "sanity check 8");
+ is_deeply(Set::Object::get_magic(\%object), [$$set],
+ "Magic detected");
+ }
+ is_deeply(Set::Object::get_magic(\%object), undef, "Magic removed");
+ $object{y} = "Yep, that's enough";
+ #Dump(\%object);
+ is($object{y}, "Yep, that's enough, world",
+ "tie magic not interefered with by _dispel_magic [reverse]");
+}
+
+require Set::Object::Weak;
+no strict 'subs';
+Set::Object::Weak->import(weak_set);
+my $s = Set::Object::Weak->new([]);
+is($s->size, 0, "Set::Object::Weak->new()");
+$s = weak_set([]);
+is($s->size, 0, "weak_set()");
+
+# ok, may as well put it there too
+my $ws = Set::Object::weak_set(["ø"]);
+is($ws->size, 0, "Set::Object::weak_set");
+
+# test example in the SYNOPSIS
+$ws = Set::Object::Weak->new( 0, "", {}, [], (bless {}, "Object") );
+is($ws->size, 2, "made a weak set");
+
+$ws = Set::Object::Weak::set("one");
+is($ws->size, 1, "Set::Object::Weak::set() inserts its arguments");
+
+{package Tie::Scalar::Null;
+ sub TIEHASH {
+ my ($class) = @_;
+ return bless {}, $class;
+ }
+ sub FETCH {
+ $DB::single = 1;
+ $_[0]->{$_[1]};
+ }
+ sub STORE {
+ $DB::single = 1;
+ $_[0]->{$_[1]} = "$_[2], world";
+ }
+ sub FIRSTKEY {
+ each %{$_[0]};
+ }
+ sub NEXTKEY {
+ each %{$_[0]};
+ }
+}
Modified: packages/libset-object-perl/branches/upstream/current/t/scalar/compare.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/t/scalar/compare.t?rev=4910&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/compare.t (original)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/compare.t Thu Mar 1 00:26:01 2007
@@ -10,7 +10,7 @@
my $n = Set::Object->new(qw());
my $o = Set::Object->new(qw());
-print "1..23\n";
+print "1..24\n";
print "not " unless $t == $u;
print "ok 1\n";
@@ -85,6 +85,10 @@
print "ok 23\n";
}
+# [cpan #24965]
+print "not " unless $n->compare($o) eq 'equal';
+print "ok 24\n";
+
sub show {
my $z = shift;
More information about the Pkg-perl-cvs-commits
mailing list