r3303 - in /packages/libset-object-perl/branches/upstream/current:
Changes.pod META.yml Object.xs README lib/Set/Object.pm
t/object/remove.t
gregoa-guest at users.alioth.debian.org
gregoa-guest at users.alioth.debian.org
Fri Jul 21 12:00:05 UTC 2006
Author: gregoa-guest
Date: Fri Jul 21 12:00:04 2006
New Revision: 3303
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=3303
Log:
Load /tmp/tmp.BLUoDI7395/libset-object-perl-1.16 into
packages/libset-object-perl/branches/upstream/current.
Modified:
packages/libset-object-perl/branches/upstream/current/Changes.pod
packages/libset-object-perl/branches/upstream/current/META.yml
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/object/remove.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=3303&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/Changes.pod (original)
+++ packages/libset-object-perl/branches/upstream/current/Changes.pod Fri Jul 21 12:00:04 2006
@@ -1,5 +1,15 @@
=head1 REVISION HISTORY FOR Set::Object
+
+=head1 1.16, 18 Jul 2006
+
+=over
+
+=item *
+
+weak reference support
+
+=back
=head1 1.15, 21 Jun 2006
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=3303&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/META.yml (original)
+++ packages/libset-object-perl/branches/upstream/current/META.yml Fri Jul 21 12:00:04 2006
@@ -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.15
+version: 1.16
version_from: lib/Set/Object.pm
installdirs: site
requires:
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=3303&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/Object.xs (original)
+++ packages/libset-object-perl/branches/upstream/current/Object.xs Fri Jul 21 12:00:04 2006
@@ -12,12 +12,25 @@
#include "ppport.h"
// for debugging object-related functions
-#define IF_DEBUG(e)
+#if 0
+#define DEBUG(msg, e...) warn("# (" __FILE__ ":%d): " msg, __LINE__, ##e)
+#else
+#define DEBUG(msg, e...)
+#endif
// for debugging scalar-related functions
#define IF_REMOVE_DEBUG(e)
#define IF_INSERT_DEBUG(e)
+// for debugging weakref-related functions
+#if 0
+#define SPELL_DEBUG(msg, e...) DEBUG(msg, ##e)
+#else
+#define SPELL_DEBUG(msg, e...)
+#endif
+
+#define SET_OBJECT_MAGIC_backref (char)0x9f
+
typedef struct _BUCKET
{
SV** sv;
@@ -28,6 +41,7 @@
{
BUCKET* bucket;
I32 buckets, elems;
+ SV* is_weak;
HV* flat;
} ISET;
@@ -45,7 +59,7 @@
New(0, pb->sv, 1, SV*);
pb->sv[0] = sv;
pb->n = 1;
- IF_DEBUG(warn("inserting %p in bucket %p offset %d\n", sv, pb, 0));
+ DEBUG("inserting 0x%.8x in bucket 0x%.8x offset %d", sv, pb, 0);
}
else
{
@@ -71,7 +85,7 @@
*hole = sv;
- IF_DEBUG(warn("inserting %p in bucket %p offset %d\n", sv, pb, iter - pb->sv));
+ DEBUG("inserting 0x%.8x in bucket 0x%.8x offset %d", sv, pb, iter - pb->sv);
}
return 1;
@@ -120,7 +134,7 @@
return 0;
}
- //IF_DEBUG(warn("Checking for existance of %s", SvPV_nolen(sv)));
+ //DEBUG("Checking for existance of %s", SvPV_nolen(sv));
//SvGETMAGIC(sv);
IF_REMOVE_DEBUG(warn("iset_remove_scalar(%x): sv (%x, rc = %d, str= '%s')!", s, sv, SvREFCNT(sv), SvPV_nolen(sv)));
@@ -178,8 +192,13 @@
{
++s->elems;
++ins;
- SvREFCNT_inc(el);
- IF_DEBUG(warn("rc of %p bumped to %d\n", el, SvREFCNT(el)));
+ if (s->is_weak) {
+ DEBUG("rc of 0x%.8x left as-is, casting magic", el);
+ _cast_magic(s, el);
+ } else {
+ SvREFCNT_inc(el);
+ DEBUG("rc of 0x%.8x bumped to %d", el, SvREFCNT(el));
+ }
}
if (s->elems > s->buckets)
@@ -190,7 +209,7 @@
BUCKET *bucket_first, *bucket_iter, *bucket_last, *new_bucket;
int i;
- IF_DEBUG(warn("Reindexing, n = %d\n", s->elems));
+ DEBUG("Reindexing, n = %d", s->elems);
Renew(s->bucket, newn, BUCKET);
Zero(s->bucket + oldn, oldn, BUCKET);
@@ -225,8 +244,8 @@
}
new_bucket = bucket_first + index;
- IF_DEBUG(warn("%p moved from bucket %d:%p to %d:%p",
- sv, i, bucket_iter, index, new_bucket));
+ DEBUG("0x%.8x moved from bucket %d:0x%.8x to %d:0x%.8x",
+ sv, i, bucket_iter, index, new_bucket);
insert_in_bucket(new_bucket, sv);
}
@@ -269,12 +288,18 @@
{
if (*el_iter)
{
- IF_DEBUG(warn("freeing %p, rc = %d, bucket = %p(%d) pos = %d\n",
+ DEBUG("freeing 0x%.8x, rc = %d, bucket = 0x%.8x(%d) pos = %d",
*el_iter, SvREFCNT(*el_iter),
bucket_iter, bucket_iter - s->bucket,
- el_iter - bucket_iter->sv));
-
- SvREFCNT_dec(*el_iter);
+ el_iter - bucket_iter->sv);
+
+ if (s->is_weak) {
+ SPELL_DEBUG("dispelling magic");
+ _dispel_magic(s,*el_iter);
+ } else {
+ SPELL_DEBUG("removing element");
+ SvREFCNT_dec(*el_iter);
+ }
*el_iter = 0;
}
}
@@ -292,6 +317,239 @@
}
+MAGIC*
+_detect_magic(SV* sv) {
+ return mg_find(sv, SET_OBJECT_MAGIC_backref);
+}
+
+void
+_dispel_magic(ISET* s, SV* sv) {
+ SV* self_svrv = s->is_weak;
+ MAGIC* mg = _detect_magic(sv);
+ SPELL_DEBUG("dispelling magic from 0x%.8x (self = 0x%.8x, mg = 0x%.8x)",
+ sv, self_svrv, mg);
+ if (mg) {
+ AV* wand = mg->mg_obj;
+ SV ** const svp = AvARRAY(wand);
+ I32 i = AvFILLp(wand);
+ int c = 0;
+
+ while (i >= 0) {
+ if (svp[i] && SvIV(svp[i])) {
+ ISET* o = INT2PTR(ISET*, SvIV(svp[i]));
+ if (s == o) {
+ /*
+ SPELL_DEBUG("dropping RC of 0x%.8x from %d to %d",
+ svp[i], SvREFCNT(svp[i]), SvREFCNT(svp[i])-1);
+ SvREFCNT_dec(svp[i]);
+ */
+ svp[i] = newSViv(0);
+ } else {
+ c++;
+ }
+ }
+ i--;
+ }
+ if (!c) {
+ /* we should clear the magic, really. */
+ MAGIC* last = 0;
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ if (mg->mg_type == SET_OBJECT_MAGIC_backref) {
+ if (last) {
+ last->mg_moremagic = mg->mg_moremagic;
+ break;
+ } else if (mg->mg_moremagic) {
+ SvMAGIC(sv) = mg->mg_moremagic;
+ } else {
+ SvMAGIC(sv) = 0;
+ SvAMAGIC_off(sv);
+ }
+ }
+ last=mg;
+ }
+ }
+ }
+}
+
+void
+_fiddle_strength(ISET* s, int strong) {
+
+ BUCKET* bucket_iter = s->bucket;
+ BUCKET* bucket_last = bucket_iter + s->buckets;
+
+ for (; bucket_iter != bucket_last; ++bucket_iter)
+ {
+ SV **el_iter, **el_last;
+
+ if (!bucket_iter->sv)
+ continue;
+
+ el_iter = bucket_iter->sv;
+ el_last = el_iter + bucket_iter->n;
+
+ for (; el_iter != el_last; ++el_iter)
+ if (*el_iter) {
+ if (strong) {
+ _dispel_magic(s, *el_iter);
+ SvREFCNT_inc(*el_iter);
+ DEBUG("bumped RC of 0x%.8x to %d", *el_iter,
+ SvREFCNT(*el_iter));
+ }
+ else {
+ _cast_magic(s, *el_iter);
+ SvREFCNT_dec(*el_iter);
+ DEBUG("reduced RC of 0x%.8x to %d", *el_iter,
+ SvREFCNT(*el_iter));
+ }
+ }
+ }
+}
+
+int
+_spell_effect(pTHX_ SV *sv, MAGIC *mg)
+{
+ AV * const av = (AV*)mg->mg_obj;
+ SV ** const svp = AvARRAY(av);
+ I32 i = AvFILLp(av);
+
+ SPELL_DEBUG("_spell_effect (SV=0x%.8x, av_len=%d)", sv,
+ av_len(av));
+
+ while (i >= 0) {
+ SPELL_DEBUG("_spell_effect %d", i);
+ if (svp[i] && SvIV(svp[i])) {
+ SPELL_DEBUG("_spell_effect i = %d, SV = 0x%.8x", i, svp[i]);
+ ISET* s = INT2PTR(ISET*, SvIV(svp[i]));
+ if (!s->is_weak)
+ Perl_croak(aTHX_ "panic: set_object_magic_killbackrefs (flags=%"UVxf")",
+ (UV)SvFLAGS(svp[i]));
+ /* SvREFCNT_dec(svp[i]); */
+ svp[i] = newSViv(0);
+ if (iset_remove_one(s, sv, 1) != 1) {
+ warn("Set::Object magic backref hook called on non-existent item (0x%x, self = 0x%x)", sv, s->is_weak);
+ };
+ }
+ i--;
+ }
+}
+
+static MGVTBL SET_OBJECT_vtbl_backref =
+ {0, 0, 0, 0, MEMBER_TO_FPTR(_spell_effect)};
+
+void
+_cast_magic(ISET* s, SV* sv) {
+ SV* self_svrv = s->is_weak;
+ AV* wand;
+ MGVTBL *vtable = &SET_OBJECT_vtbl_backref;
+ MAGIC* mg;
+ SV ** svp;
+ int how = 0;
+ I32 i,l,free;
+ how = 0x9f; // (int)SET_OBJECT_MAGIC_backref;
+
+ mg = _detect_magic(sv);
+ if (mg) {
+ SPELL_DEBUG("sv_magicext reusing wand 0x%.8x for 0x%.8x", wand, sv);
+ wand = mg->mg_obj;
+ }
+ else {
+ wand=newAV();
+ SPELL_DEBUG("sv_magicext(0x%.8x, 0x%.8x, %ld, 0x%.8x, NULL, 0)", sv, wand, how, vtable);
+ sv_magicext(sv, wand, how, vtable, NULL, 0);
+ SvRMAGICAL_on(sv);
+ }
+
+ svp = AvARRAY(wand);
+ i = AvFILLp(wand);
+ free = -1;
+
+ while (i >= 0) {
+ if (svp[i] && SvIV(svp[i])) {
+ ISET* o = INT2PTR(ISET*, SvIV(svp[i]));
+ if (s == o)
+ return;
+ } else {
+ free = i;
+ }
+ i = i - 1;
+ }
+
+ if (free == -1) {
+ SPELL_DEBUG("casting self 0x%.8x with av_push", self_svrv, free);
+ av_push(wand, self_svrv);
+ } else {
+ SPELL_DEBUG("casting self 0x%.8x to slot %d", self_svrv, free);
+ svp[free] = self_svrv;
+ }
+ /*
+ SvREFCNT_inc(self_svrv);
+ */
+}
+
+int
+iset_remove_one(ISET* s, SV* el, int spell_in_progress)
+{
+ SV *referant;
+ I32 hash, index;
+ SV **el_iter, **el_last, **el_out_iter;
+ BUCKET* bucket;
+
+ DEBUG("removing scalar 0x%.8x from set 0x%.8x", el, s);
+
+ if (SvOK(el) && !SvROK(el)) {
+ DEBUG("scalar is not a ref (flags = 0x%.8x)", SvFLAGS(el));
+ if (s->flat) {
+ DEBUG("calling remove_scalar for 0x%.8x", el);
+ if (iset_remove_scalar(s, el))
+ return 1;
+ }
+ return 0;
+ }
+
+ referant = (spell_in_progress ? el : SvRV(el));
+ hash = ISET_HASH(referant);
+ index = hash & (s->buckets - 1);
+ bucket = s->bucket + index;
+
+ if (s->buckets == 0)
+ return 0;
+
+ if (!bucket->sv)
+ return 0;
+
+ el_iter = bucket->sv;
+ el_out_iter = el_iter;
+ el_last = el_iter + bucket->n;
+ DEBUG("remove: el_last = 0x%.8x, el_iter = 0x%.8x", el_last, el_iter);
+
+ for (; el_iter != el_last; ++el_iter)
+ {
+ if (*el_iter == referant)
+ {
+ if (s->is_weak) {
+ if (!spell_in_progress) {
+ SPELL_DEBUG("Removing ST(0x%.8x) magic", referant);
+ _dispel_magic(s,referant);
+ } else {
+ SPELL_DEBUG("Not removing ST(0x%.8x) magic (spell in progress)", referant);
+
+ }
+ } else {
+ SPELL_DEBUG("Not removing ST(0x%.8x) magic from Muggle", referant);
+ SvREFCNT_dec(referant);
+ }
+ *el_iter = 0;
+ --s->elems;
+ return 1;
+ }
+ else
+ {
+ SPELL_DEBUG("ST(0x%.8x) != 0x%.8x", referant, *el_iter);
+ }
+ }
+ return 0;
+}
+
MODULE = Set::Object PACKAGE = Set::Object
PROTOTYPES: DISABLE
@@ -314,6 +572,7 @@
s->bucket = 0;
s->buckets = 0;
s->flat = 0;
+ s->is_weak = 0;
// warning: cast from pointer to integer of different size
isv = newSViv( PTR2IV(s) );
@@ -329,7 +588,7 @@
ISET_INSERT(s, ST(item));
}
- IF_DEBUG(warn("set!\n"));
+ DEBUG("set!");
PUSHs(self);
XSRETURN(1);
@@ -351,7 +610,7 @@
}
if ISET_INSERT(s, ST(item))
inserted++;
- IF_DEBUG(warn("inserting %p %p size = %d\n", ST(item), SvRV(ST(item)), s->elems));
+ DEBUG("inserting 0x%.8x 0x%.8x size = %d", ST(item), SvRV(ST(item)), s->elems);
}
@@ -372,45 +631,8 @@
for (item = 1; item < items; ++item)
{
SV* el = ST(item);
- SV *rv;
-
- if (!SvROK(el)) {
- if (s->flat) {
- IF_REMOVE_DEBUG(warn("Calling remove_scalar for ST(%d)", item));
- if (iset_remove_scalar(s, el))
- removed++;
- }
- continue;
- }
- IF_REMOVE_DEBUG(warn("using object remove for ST(%d)", item));
-
- rv = SvRV(el);
- hash = ISET_HASH(rv);
- index = hash & (s->buckets - 1);
- bucket = s->bucket + index;
-
-
- if (s->buckets == 0)
- goto remove_out;
-
- if (!bucket->sv)
- continue;
-
- el_iter = bucket->sv;
- el_out_iter = el_iter;
- el_last = el_iter + bucket->n;
-
- for (; el_iter != el_last; ++el_iter)
- {
- if (*el_iter == rv)
- {
- SvREFCNT_dec(rv);
- *el_iter = 0;
- --s->elems;
- removed++;
- break;
- }
- }
+
+ removed += iset_remove_one(s, el, 0);
}
remove_out:
XSRETURN_IV(removed);
@@ -489,7 +711,7 @@
SV* rv;
if (!SvROK(el)) {
- IF_DEBUG(warn("includes! el = %s\n", SvPV_nolen(el)));
+ DEBUG("includes! el = %s", SvPV_nolen(el));
if (!iset_includes_scalar(s, el))
XSRETURN_NO;
goto next;
@@ -504,8 +726,8 @@
index = hash & (s->buckets - 1);
bucket = s->bucket + index;
- IF_DEBUG(warn("includes: looking for %p in bucket %d:%p",
- rv, index, bucket));
+ DEBUG("includes: looking for 0x%.8x in bucket %d:0x%.8x",
+ rv, index, bucket);
if (!bucket->sv)
XSRETURN_NO;
@@ -590,13 +812,56 @@
CODE:
ISET* s = INT2PTR(ISET*, SvIV(SvRV(self)));
- IF_DEBUG(warn("aargh!\n"));
+ DEBUG("aargh!");
iset_clear(s);
if (s->flat) {
hv_undef(s->flat);
}
Safefree(s);
+int
+is_weak(self)
+ SV* self
+
+ CODE:
+ ISET* s = INT2PTR(ISET*, SvIV(SvRV(self)));
+
+ RETVAL = s->is_weak;
+
+ OUTPUT: RETVAL
+
+void
+weaken(self)
+ SV* self
+
+ CODE:
+ ISET* s = INT2PTR(ISET*, SvIV(SvRV(self)));
+
+ if (s->is_weak)
+ XSRETURN_UNDEF;
+
+ DEBUG("weakening set (0x%.8x)", SvRV(self));
+
+ s->is_weak = SvRV(self);
+
+ _fiddle_strength(s, 0);
+
+void
+strengthen(self)
+ SV* self
+
+ CODE:
+ ISET* s = INT2PTR(ISET*, SvIV(SvRV(self)));
+
+ if (!s->is_weak)
+ XSRETURN_UNDEF;
+
+ DEBUG("strengthening set (0x%.8x)", SvRV(self));
+
+ _fiddle_strength(s, 1);
+
+ s->is_weak = 0;
+
/* Here are some functions from Scalar::Util; they are so simple,
that it isn't worth making a dependancy on that module. */
@@ -639,6 +904,31 @@
OUTPUT:
RETVAL
+void
+get_magic(sv)
+ SV *sv
+PROTOTYPE: $
+CODE:
+ MAGIC* mg;
+ SV* magic;
+ if (! SvROK(sv)) {
+ warn("tried to get magic from non-reference");
+ XSRETURN_UNDEF;
+ }
+
+ if (! (mg = _detect_magic(SvRV(sv))) )
+ XSRETURN_UNDEF;
+
+ SPELL_DEBUG("found magic on 0x%.8x - 0x%.8x", sv, mg);
+ SPELL_DEBUG("mg_obj = 0x%.8x", mg->mg_obj);
+
+ /*magic = newSV(0);
+ SvRV(magic) = mg->mg_obj;
+ SvROK_on(magic); */
+ POPs;
+ magic = newRV_inc(mg->mg_obj);
+ PUSHs(magic);
+ XSRETURN(1);
char *
blessed(sv)
@@ -811,6 +1101,7 @@
s->bucket = 0;
s->buckets = 0;
s->flat = 0;
+ s->is_weak = 0;
if (!SvROK(obj)) {
Perl_croak(aTHX_ "Set::Object::STORABLE_thaw passed a non-reference");
@@ -832,7 +1123,7 @@
ISET_INSERT(s, ST(item));
}
- IF_DEBUG(warn("set!\n"));
+ DEBUG("set!");
PUSHs(obj);
XSRETURN(1);
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=3303&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/README (original)
+++ packages/libset-object-perl/branches/upstream/current/README Fri Jul 21 12:00:04 2006
@@ -1,296 +1,13 @@
-NAME
- Set::Object - set of objects and strings
+README for Set::Object 1.16
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There used to be a reproduction of the man page here, but that's just
+silly.
-SYNOPSIS
- use Set::Object;
+So now I guess I should put the normal things here, like how to
+install the module, etc.
- my $set = set(); # or Set::Object->new()
+Oh, look, just go and read another module's README. It's just the
+same, honest. Nothing to see here, move along.
- $set->insert(@thingies);
- $set->remove(@thingies);
-
- @items = @$set; # or $set->members;
-
- $union = $set1 + $set2;
- $intersection = $set1 * $set2;
- $difference = $set1 - $set2;
- $symmetric_difference = $set1 % $set2;
-
- print "set1 is a proper subset of set2"
- if $set1 < $set2;
-
- print "set1 is a subset of set2"
- if $set1 <= $set2;
-
- # common idiom - iterate over any pure Perl structure
- use Set::Object qw(reftype);
- my @stack = $root;
- my $seen = Set::Object->new(@stack);
- while (my $object = pop @stack) {
- if (reftype $object eq "HASH") {
- # do something with hash members
-
- # add the new nodes to the stack
- push @stack, grep { ref $_ && $seen->insert($_) }
- values %$object;
- }
- elsif (reftype $object eq "ARRAY") {
- # do something with array members
-
- # add the new nodes to the stack
- push @stack, grep { ref $_ && $seen->insert($_) }
- @$object;
-
- }
- elsif (reftype $object =~ /SCALAR|REF/) {
- push @stack, $$object
- if ref $$object && $seen->insert($$object);
- }
- }
-
-DESCRIPTION
- This modules implements a set of objects, that is, an unordered
- collection of objects without duplication.
-
- The term *objects* is applied loosely - for the sake of Set::Object,
- anything that is a reference is considered an object.
-
- Set::Object 1.09 and later includes support for inserting scalars
- (including the empty string, but excluding "undef") as well as objects.
- This can be thought of as (and is currently implemented as) a degenerate
- hash that only has keys and no values. Unlike objects placed into a
- Set::Object, scalars that are inserted will be flattened into strings,
- so will lose any magic (eg, tie) or other special bits that they went in
- with; only strings come out.
-
-CLASS METHODS
- new( [*list*] )
- Return a new "Set::Object" containing the elements passed in *list*.
-
-INSTANCE METHODS
- insert( [*list*] )
- Add items to the "Set::Object".
-
- Adding the same object several times is not an error, but any
- "Set::Object" will contain at most one occurence of the same object.
-
- Returns the number of elements that were actually added.
-
- includes( [*list*] )
- has( [*list*] )
- contains( [*list*] )
- Return "true" if all the objects in *list* are members of the
- "Set::Object". *list* may be empty, in which case "true" is always
- returned.
-
- member( [*item*] )
- element( [*item*] )
- Like "includes", but takes a single item to check and returns that item
- if the value is found, rather than just a true value.
-
- members
- elements
- Return the objects contained in the "Set::Object" in random (hash)
- order.
-
- size
- Return the number of elements in the "Set::Object".
-
- remove( [*list*] )
- delete( [*list*] )
- Remove objects from a "Set::Object".
-
- Removing the same object more than once, or removing an object absent
- from the "Set::Object" is not an error.
-
- Returns the number of elements that were actually removed.
-
- invert( [*list*] )
- For each item in *list*, it either removes it or adds it to the set, so
- that a change is always made.
-
- Also available as the overloaded operator "/", in which case it expects
- another set (or a single scalar element), and returns a new set that is
- the original set with all the second set's items inverted.
-
- clear
- Empty this "Set::Object".
-
- as_string
- Return a textual Smalltalk-ish representation of the "Set::Object". Also
- available as overloaded operator "".
-
- intersection( [*list*] )
- Return a new "Set::Object" containing the intersection of the
- "Set::Object"s passed as arguments.
-
- Also available as overloaded operator "*".
-
- union( [*list*] )
- Return a new "Set::Object" containing the union of the "Set::Object"s
- passed as arguments.
-
- Also available as overloaded operator "+".
-
- difference ( *set* )
- Return a new "Set::Object" containing the members of the first
- (invocant) set with the passed "Set::Object"s' elements removed.
-
- Also available as overloaded operator "-".
-
- unique ( *set* )
- symmetric_difference ( *set* )
- Return a new "Set::Object" containing the members of all passed sets
- (including the invocant), with common elements removed. This will be the
- opposite (complement) of the *intersection* of the two sets.
-
- Also available as overloaded operator "%".
-
- subset( *set* )
- Return "true" if this "Set::Object" is a subset of *set*.
-
- Also available as operator "<=".
-
- proper_subset( *set* )
- Return "true" if this "Set::Object" is a proper subset of *set* Also
- available as operator "<".
-
- superset( *set* )
- Return "true" if this "Set::Object" is a superset of *set*. Also
- available as operator ">=".
-
- proper_superset( *set* )
- Return "true" if this "Set::Object" is a proper superset of *set* Also
- available as operator ">".
-
-Set::Scalar compatibility methods
- By and large, Set::Object is not and probably never will be
- feature-compatible with Set::Scalar; however the following functions are
- provided anyway.
-
- compare( *set* )
- returns one of:
-
- "proper intersect"
- "proper subset"
- "proper superset"
- "equal"
- "disjoint"
-
- is_disjoint( *set* )
- Returns a true value if the two sets have no common items.
-
- as_string_callback( *set* )
- Allows you to define a custom stringify function. This is only a class
- method. If you want anything fancier than this, you should sub-class
- Set::Object.
-
-FUNCTIONS
- The following functions are defined by the Set::Object XS code for
- convenience; they are largely identical to the versions in the
- Scalar::Util module, but there are a couple that provide functions not
- catered to by that module.
-
- Please use the versions in Scalar::Util in preference to these
- functions.
-
- blessed
- Returns a true value if the passed reference (RV) is blessed. See
- also Acme::Holy.
-
- reftype
- A bit like the perl built-in "ref" function, but returns the *type*
- of reference; ie, if the reference is blessed then it returns what
- "ref" would have if it were not blessed. Useful for "seeing through"
- blessed references.
-
- refaddr
- Returns the memory address of a scalar. Warning: this is *not*
- guaranteed to be unique for scalars created in a program; memory
- might get re-used!
-
- is_int, is_string, is_double
- A quick way of checking the three bits on scalars - IOK (is_int),
- NOK (is_double) and POK (is_string). Note that the exact behaviour
- of when these bits get set is not defined by the perl API.
-
- This function returns the "p" versions of the macro (SvIOKp, etc);
- use with caution.
-
- is_overloaded
- A quick way to check if an object has overload magic on it.
-
- ish_int
- This function returns true, if the value it is passed looks like it
- *already is* a representation of an *integer*. This is so that you
- can decide whether the value passed is a hash key or an array index.
-
- is_key
- This function returns true, if the value it is passed looks more
- like an *index* to a collection than a *value* of a collection.
-
- But wait, you say - Set::Object has no indices, one of the
- fundamental properties of a Set is that it is an *unordered
- collection*. Which means *no indices*. Well, if this module were
- ever to be derived to be a more general multi-purpose collection,
- then this (and "ish_int") might be a good function to use to
- distinguish different types of indexes from values.
-
-PERFORMANCE
- The following benchmark compares "Set::Object" with using a hash to
- emulate a set-like collection (this is an old benchmark, but still holds
- true):
-
- use Set::Object;
-
- package Obj;
- sub new { bless { } }
-
- @els = map { Obj->new() } 1..1000;
-
- require Benchmark;
-
- Benchmark::timethese(100, {
- 'Control' => sub { },
- 'H insert' => sub { my %h = (); @h{@els} = @els; },
- 'S insert' => sub { my $s = Set::Object->new(); $s->insert(@els) },
- } );
-
- %gh = ();
- @gh{@els} = @els;
-
- $gs = Set::Object->new(@els);
- $el = $els[33];
-
- Benchmark::timethese(100_000, {
- 'H lookup' => sub { exists $gh{33} },
- 'S lookup' => sub { $gs->includes($el) }
- } );
-
- On my computer the results are:
-
- Benchmark: timing 100 iterations of Control, H insert, S insert...
- Control: 0 secs ( 0.01 usr 0.00 sys = 0.01 cpu)
- (warning: too few iterations for a reliable count)
- H insert: 68 secs (67.81 usr 0.00 sys = 67.81 cpu)
- S insert: 9 secs ( 8.81 usr 0.00 sys = 8.81 cpu)
- Benchmark: timing 100000 iterations of H lookup, S lookup...
- H lookup: 7 secs ( 7.14 usr 0.00 sys = 7.14 cpu)
- S lookup: 6 secs ( 5.94 usr 0.00 sys = 5.94 cpu)
-
-AUTHOR
- Original Set::Object module by Jean-Louis Leroy, <jll at skynet.be>
-
- Set::Scalar compatibility, XS debugging and other maintainership
- courtesy of Sam Vilain, <samv at cpan.org>
-
-LICENCE
- Copyright (c) 1998-1999, Jean-Louis Leroy. All Rights Reserved. This
- module is free software. It may be used, redistributed and/or modified
- under the terms of the Perl Artistic License
-
- Portions Copyright (c) 2003 - 2005, Sam Vilain. Same license.
-
-SEE ALSO
- perl(1), perltie(1), Set::Scalar, overload.pm
-
+Cheers,
+Sam.
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=3303&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 Fri Jul 21 12:00:04 2006
@@ -123,6 +123,21 @@
Returns the number of elements that were actually removed.
+=head2 weaken
+
+Makes all the references in the set "weak" - that is, they do not
+increase the reference count of the object they point to, just like
+L<Scalar::Util|Scalar::Util>'s C<weaken> function.
+
+This was introduced with Set::Object 1.16, and uses a brand new type
+of magic. B<Use with caution>. If you get segfaults when you use
+C<weaken>, please reduce your problem to a test script before
+submission.
+
+=head2 strengthen
+
+Turns a weak set back into a normal one.
+
=head2 invert( [I<list>] )
For each item in I<list>, it either removes it or adds it to the set,
@@ -282,6 +297,15 @@
be a more general multi-purpose collection, then this (and C<ish_int>)
might be a good function to use to distinguish different types of
indexes from values.
+
+=item B<get_magic>
+
+Pass to a scalar, and get the magick wand (C<mg_obj>) used by the weak
+set implementation. The return will be a list of integers which are
+pointers to the actual C<ISET> structure. Whatever you do don't
+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
@@ -332,8 +356,11 @@
Original Set::Object module by Jean-Louis Leroy, <jll at skynet.be>
-Set::Scalar compatibility, XS debugging and other maintainership
-courtesy of Sam Vilain, <samv at cpan.org>
+Set::Scalar compatibility, XS debugging, weak references support and
+general maintainership courtesy of Sam Vilain, <samv at cpan.org>.
+Maximum respect to those who send me test scripts, enhancements, etc
+as patches against my git tree, browsable at
+L<http://utsl.gen.nz/gitweb/?p=Set-Object>.
=head1 LICENCE
@@ -368,7 +395,7 @@
@EXPORT_OK = qw( ish_int is_int is_string is_double blessed reftype
refaddr is_overloaded is_object is_key set );
-$VERSION = '1.15';
+$VERSION = '1.16';
bootstrap Set::Object $VERSION;
@@ -810,7 +837,7 @@
sub STORABLE_freeze {
my $obj = shift;
my $am_cloning = shift;
- return ("v2", [ $obj->members ]);
+ return ("v3-" . ($obj->is_weak ? "w" : "s"), [ $obj->members ]);
}
use Devel::Peek qw(Dump);
@@ -819,8 +846,21 @@
#print Dump $_ foreach (@_);
$DB::single = 1;
- if ( $_[2] and $_[2] eq "v2" ) {
- @_ = (@_[0,1], "", @{ $_[3] });
+ if ( $_[2] ) {
+ if ( $_[2] eq "v2" ) {
+ @_ = (@_[0,1], "", @{ $_[3] });
+ }
+ elsif ( $_[2] =~ m/^v3-(w|s)/ ) {
+ @_ = (@_[0,1], "", @{ $_[3] });
+ if ( $1 eq "w" ) {
+ my $self = shift;
+ $self->_STORABLE_thaw(@_);
+ $self->weaken();
+ return;
+ }
+ } else {
+ croak("Unrecognised Set::Object Storable version $_[2]");
+ }
}
goto &_STORABLE_thaw;
Modified: packages/libset-object-perl/branches/upstream/current/t/object/remove.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libset-object-perl/branches/upstream/current/t/object/remove.t?rev=3303&op=diff
==============================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/remove.t (original)
+++ packages/libset-object-perl/branches/upstream/current/t/object/remove.t Fri Jul 21 12:00:04 2006
@@ -13,17 +13,19 @@
$simpsons = Set::Object->new($homer, $marge, $bart, $lisa, $maggie);
-print "1..3\n";
+use Test::More tests => 7;
$removed = $simpsons->remove($homer);
-print 'not ' unless $simpsons->size() == 4 && $removed == 1
- && $simpsons == Set::Object->new($marge, $bart, $lisa, $maggie);
-print "ok 1\n";
+
+is($simpsons->size(), 4, "new size correct after remove");
+is($removed, 1, "remove returned number of elements removed");
+is($simpsons, Set::Object->new($marge, $bart, $lisa, $maggie),
+ "set contents correct");
$removed = $simpsons->remove($burns);
-print 'not ' unless $simpsons->size() == 4 && $removed == 0;
-print "ok 2\n";
+is($simpsons->size(), 4, "remove of non-member didn't reduce size");
+is($removed, 0, "remove returned no elements removed");
$removed = $simpsons->remove($patty, $marge, $selma);
-print 'not ' unless $simpsons->size() == 3 && $removed == 1;
-print "ok 3\n";
+is($simpsons->size(), 3, "remove of mixed members & non-members");
+is($removed, 1, "remove returned correct num of elements removed");
More information about the Pkg-perl-cvs-commits
mailing list