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