r884 - in packages/libset-object-perl/branches/upstream/current: .
lib/Set t t/ingy t/object t/scalar
Gunnar Wolf
gwolf at costa.debian.org
Sun Jul 17 08:09:10 UTC 2005
Author: gwolf
Date: 2005-04-05 22:40:15 +0000 (Tue, 05 Apr 2005)
New Revision: 884
Added:
packages/libset-object-perl/branches/upstream/current/t/ingy/
packages/libset-object-perl/branches/upstream/current/t/ingy/arrayref.t
packages/libset-object-perl/branches/upstream/current/t/scalar/
packages/libset-object-perl/branches/upstream/current/t/scalar/basic.t
packages/libset-object-perl/branches/upstream/current/t/scalar/basic_overload.t
packages/libset-object-perl/branches/upstream/current/t/scalar/boolean.t
packages/libset-object-perl/branches/upstream/current/t/scalar/clear.t
packages/libset-object-perl/branches/upstream/current/t/scalar/compare.t
packages/libset-object-perl/branches/upstream/current/t/scalar/custom_display.t
packages/libset-object-perl/branches/upstream/current/t/scalar/difference.t
packages/libset-object-perl/branches/upstream/current/t/scalar/each.t
packages/libset-object-perl/branches/upstream/current/t/scalar/has.t
packages/libset-object-perl/branches/upstream/current/t/scalar/intersection.t
packages/libset-object-perl/branches/upstream/current/t/scalar/member.t
packages/libset-object-perl/branches/upstream/current/t/scalar/misc.t
packages/libset-object-perl/branches/upstream/current/t/scalar/set_set.t
packages/libset-object-perl/branches/upstream/current/t/scalar/symmdiff.t
packages/libset-object-perl/branches/upstream/current/t/scalar/union.t
packages/libset-object-perl/branches/upstream/current/t/scalar/unique.t
Modified:
packages/libset-object-perl/branches/upstream/current/Changes
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/object/Person.pm
packages/libset-object-perl/branches/upstream/current/t/object/abuse.t
packages/libset-object-perl/branches/upstream/current/t/object/clear.t
packages/libset-object-perl/branches/upstream/current/t/object/difference.t
packages/libset-object-perl/branches/upstream/current/t/object/equal.t
packages/libset-object-perl/branches/upstream/current/t/object/flags.t
packages/libset-object-perl/branches/upstream/current/t/object/includes.t
packages/libset-object-perl/branches/upstream/current/t/object/insert.t
packages/libset-object-perl/branches/upstream/current/t/object/intersection.t
packages/libset-object-perl/branches/upstream/current/t/object/members.t
packages/libset-object-perl/branches/upstream/current/t/object/refcount.t
packages/libset-object-perl/branches/upstream/current/t/object/remove.t
packages/libset-object-perl/branches/upstream/current/t/object/subsuper.t
packages/libset-object-perl/branches/upstream/current/t/object/symmetric_difference.t
packages/libset-object-perl/branches/upstream/current/t/object/union.t
Log:
Load /tmp/tmp.ay7Bng/libset-object-perl-1.10 into
packages/libset-object-perl/branches/upstream/current.
Modified: packages/libset-object-perl/branches/upstream/current/Changes
===================================================================
--- packages/libset-object-perl/branches/upstream/current/Changes 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/Changes 2005-04-05 22:40:15 UTC (rev 884)
@@ -66,3 +66,23 @@
segfault when taking a difference between sets of exactly
31 and 0 size. Same root fault as the previous bug, this
time I have a test case for it, too.
+
+1.08_01 12 Jan 2005
+ - First attempt at adding support for scalars. This version
+ tries to work as closely to Set::Scalar as possible.
+
+ This approach will not be continued unless there are a lot
+ of requests for it to be implemented. I think it's overly
+ complicated, and not what people expect when they want a
+ Set.
+
+1.08_02 14 Jan 2005
+ - Cutting out the "Universe" representation
+ - Fixed docs
+
+1.09 26 Mar 2005
+ - added 'bool' overload operator to Set::Object. For
+ backwards compatibility, always returns true.
+
+1.10 2 Apr 2005
+ - added 'set()' constructor and use-as-array-ref interface
Modified: packages/libset-object-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libset-object-perl/branches/upstream/current/MANIFEST 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/MANIFEST 2005-04-05 22:40:15 UTC (rev 884)
@@ -2,24 +2,43 @@
Makefile.PL
MANIFEST
README
+META.yml Module meta-data (added by MakeMaker)
lib/Set/Object.pm
Object.xs
-t/equal.t
-t/clear.t
-t/difference.t
-t/flags.t
-t/includes.t
-t/insert.t
-t/intersection.t
-t/members.t
-t/Person.pm
-t/Saint.pm
-t/refcount.t
-t/remove.t
-t/subsuper.t
-t/symmetric_difference.t
-t/union.t
-META.yml Module meta-data (added by MakeMaker)
-t/abuse.t
-t/properties.t
-t/storable.t
+t/object/equal.t
+t/object/clear.t
+t/object/difference.t
+t/object/flags.t
+t/object/includes.t
+t/object/insert.t
+t/object/intersection.t
+t/object/members.t
+t/object/Person.pm
+t/object/Saint.pm
+t/object/refcount.t
+t/object/remove.t
+t/object/subsuper.t
+t/object/symmetric_difference.t
+t/object/union.t
+t/object/abuse.t
+t/object/properties.t
+t/object/storable.t
+
+t/scalar/basic_overload.t
+t/scalar/basic.t
+t/scalar/boolean.t
+t/scalar/clear.t
+t/scalar/compare.t
+t/scalar/custom_display.t
+t/scalar/difference.t
+t/scalar/each.t
+t/scalar/has.t
+t/scalar/intersection.t
+t/scalar/member.t
+t/scalar/misc.t
+t/scalar/set_set.t
+t/scalar/symmdiff.t
+t/scalar/union.t
+t/scalar/unique.t
+
+t/ingy/arrayref.t
Modified: packages/libset-object-perl/branches/upstream/current/META.yml
===================================================================
--- packages/libset-object-perl/branches/upstream/current/META.yml 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/META.yml 2005-04-05 22:40:15 UTC (rev 884)
@@ -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.08
+version: 1.10
version_from: lib/Set/Object.pm
installdirs: site
requires:
Modified: packages/libset-object-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libset-object-perl/branches/upstream/current/Makefile.PL 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/Makefile.PL 2005-04-05 22:40:15 UTC (rev 884)
@@ -8,4 +8,5 @@
'LIBS' => [''], # e.g., '-lm'
'DEFINE' => '', # e.g., '-DHAVE_SOMETHING'
'INC' => '', # e.g., '-I/usr/include/other'
+ test => { TESTS => "t/object/*.t t/scalar/*.t" },
);
Modified: packages/libset-object-perl/branches/upstream/current/Object.xs
===================================================================
--- packages/libset-object-perl/branches/upstream/current/Object.xs 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/Object.xs 2005-04-05 22:40:15 UTC (rev 884)
@@ -9,8 +9,13 @@
}
#endif
-#define IF_DEBUG(e)
+// for debugging object-related functions
+#define IF_DEBUG(e)
+// for debugging scalar-related functions
+#define IF_REMOVE_DEBUG(e)
+#define IF_INSERT_DEBUG(e)
+
typedef struct _BUCKET
{
SV** sv;
@@ -21,10 +26,16 @@
{
BUCKET* bucket;
I32 buckets, elems;
+ HV* flat;
} ISET;
#define ISET_HASH(el) ((I32) (el) >> 4)
+#define ISET_INSERT(s, item) \
+ ( SvROK(item) \
+ ? iset_insert_one(s, item) \
+ : iset_insert_scalar(s, item) )
+
int insert_in_bucket(BUCKET* pb, SV* sv)
{
if (!pb->sv)
@@ -64,11 +75,88 @@
return 1;
}
-void iset_insert_one(ISET* s, SV* rv)
+int iset_insert_scalar(ISET* s, SV* sv)
{
+ STRLEN len;
+ char* key = 0;
+ SV** oldsvref;
+
+ if (!s->flat) {
+ IF_INSERT_DEBUG(warn("iset_insert_scalar(%x): creating scalar hash", s));
+ s->flat = newHV();
+ }
+
+ //SvGETMAGIC(sv);
+ key = SvPV(sv, len);
+
+ IF_INSERT_DEBUG(warn("iset_insert_scalar(%x): sv (%x, rc = %d, str= '%s')!", s, sv, SvREFCNT(sv), SvPV_nolen(sv)));
+
+ if (!hv_exists(s->flat, key, len)) {
+
+ if (!hv_store(s->flat, key, len, &PL_sv_undef, 0)) {
+ warn("hv store failed[?] set=%x", s);
+ }
+
+ IF_INSERT_DEBUG(warn("iset_insert_scalar(%x): inserted OK!", s));
+
+ return 1;
+ }
+ else {
+
+ IF_INSERT_DEBUG(warn("iset_insert_scalar(%x): already there!", s));
+ return 0;
+ }
+
+}
+
+int iset_remove_scalar(ISET* s, SV* sv)
+{
+ STRLEN len;
+ char* key = 0;
+
+ if (!s->flat) {
+ IF_REMOVE_DEBUG(warn("iset_remove_scalar(%x): shortcut for %x(str = '%s') (no hash)", s, sv, SvPV_nolen(sv)));
+ return 0;
+ }
+
+ //IF_DEBUG(warn("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)));
+
+ key = SvPV(sv, len);
+
+ if ( hv_delete(s->flat, key, len, 0) ) {
+
+ IF_REMOVE_DEBUG(warn("iset_remove_scalar(%x): deleted key", s));
+ return 1;
+
+ } else {
+
+ IF_REMOVE_DEBUG(warn("iset_remove_scalar(%x): key not absent", s));
+ return 0;
+ }
+
+}
+
+bool iset_includes_scalar(ISET* s, SV* sv)
+{
+ if (s->flat) {
+ STRLEN len;
+ char* key = SvPV(sv, len);
+ return hv_exists(s->flat, key, len);
+ }
+ else {
+ return 0;
+ }
+}
+
+
+int iset_insert_one(ISET* s, SV* rv)
+{
BUCKET** ppb;
I32 hash, index;
SV* el;
+ int ins = 0;
if (!SvROK(rv))
{
@@ -89,6 +177,7 @@
if (insert_in_bucket(s->bucket + index, el))
{
++s->elems;
+ ++ins;
SvREFCNT_inc(el);
IF_DEBUG(warn("rc of %p bumped to %d\n", el, SvREFCNT(el)));
}
@@ -157,6 +246,8 @@
}
}
}
+
+ return ins;
}
void iset_clear(ISET* s)
@@ -218,10 +309,13 @@
SV* isv;
New(0, s, 1, ISET);
+ //warn("created set id = %x", s);
s->elems = 0;
s->bucket = 0;
s->buckets = 0;
+ s->flat = 0;
+ // warning: cast from pointer to integer of different size
isv = newSViv((IV) s);
sv_2mortal(isv);
@@ -232,7 +326,7 @@
for (item = 1; item < items; ++item)
{
- iset_insert_one(s, ST(item));
+ ISET_INSERT(s, ST(item));
}
IF_DEBUG(warn("set!\n"));
@@ -248,18 +342,43 @@
PPCODE:
ISET* s = (ISET*) SvIV(SvRV(self));
I32 item;
- int init_elems = s->elems;
+int inserted = 0;
for (item = 1; item < items; ++item)
{
- iset_insert_one(s, ST(item));
+ if (s == ST(item)) {
+ warn("INSERTING SET UP OWN ARSE");
+ }
+ if ISET_INSERT(s, ST(item))
+ inserted++;
IF_DEBUG(warn("inserting %p %p size = %d\n", ST(item), SvRV(ST(item)), s->elems));
}
- XSRETURN_IV(s->elems - init_elems);
+ XSRETURN_IV(inserted);
void
+_(self, ...)
+ SV* self;
+
+ CODE:
+ ISET* s = (ISET*) SvIV(SvRV(self));
+ SV* flat;
+
+ POPs;
+
+ if (!s->flat) {
+ IF_INSERT_DEBUG(warn("iset_internal(%x): creating hashes", s));
+ s->flat = newHV();
+ }
+
+ flat = newRV_inc(s->flat);
+
+ SvREFCNT_inc(flat);
+ PUSHs(sv_2mortal(flat));
+ XSRETURN(1);
+
+void
remove(self, ...)
SV* self;
@@ -269,19 +388,31 @@
I32 hash, index, item;
SV **el_iter, **el_last, **el_out_iter;
BUCKET* bucket;
- int init_elems = s->elems;
+ int removed = 0;
- if (s->buckets == 0)
- goto remove_out;
-
for (item = 1; item < items; ++item)
{
SV* el = ST(item);
+
+ 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));
+
SV* 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;
@@ -296,20 +427,44 @@
SvREFCNT_dec(rv);
*el_iter = 0;
--s->elems;
+ removed++;
break;
}
}
}
remove_out:
- XSRETURN_IV(init_elems - s->elems);
+ XSRETURN_IV(removed);
int
+is_null(self)
+ SV* self;
+
+ CODE:
+ ISET* s = (ISET*) SvIV(SvRV(self));
+
+ if (s->elems)
+ XSRETURN_UNDEF;
+
+ if (s->flat) {
+ if (HvUSEDKEYS(s->flat)) {
+ //warn("got some keys: %d\n", HvUSEDKEYS(s->flat));
+ XSRETURN_UNDEF;
+ }
+ }
+
+ RETVAL = 1;
+
+ OUTPUT: RETVAL
+
+int
size(self)
SV* self;
CODE:
+ ISET* s = (ISET*) SvIV(SvRV(self));
- RETVAL = ((ISET*) SvIV(SvRV(self)))->elems;
+ RETVAL = s->elems + (s->flat ? HvKEYS(s->flat) : 0);
+
OUTPUT: RETVAL
@@ -353,8 +508,12 @@
SV* el = ST(item);
SV* rv;
- if (!SvROK(el))
- XSRETURN_NO;
+ if (!SvROK(el)) {
+ IF_DEBUG(warn("includes! el = %s\n", SvPV_nolen(el)));
+ if (!iset_includes_scalar(s, el))
+ XSRETURN_NO;
+ goto next;
+ }
rv = SvRV(el);
@@ -396,7 +555,7 @@
BUCKET* bucket_iter = s->bucket;
BUCKET* bucket_last = bucket_iter + s->buckets;
- EXTEND(sp, s->elems);
+ EXTEND(sp, s->elems + (s->flat ? HvUSEDKEYS(s->flat) : 0) );
for (; bucket_iter != bucket_last; ++bucket_iter)
{
@@ -421,14 +580,30 @@
}
}
+ if (s->flat) {
+ int i = 0, num = hv_iterinit(s->flat);
+
+ while (i++ < num) {
+ HE* he = hv_iternext(s->flat);
+
+ PUSHs(HeSVKEY_force(he));
+ }
+ }
+//warn("that's all, folks");
+
void
clear(self)
SV* self
CODE:
+ ISET* s = (ISET*) SvIV(SvRV(self));
- iset_clear((ISET*) SvIV(SvRV(self)));
-
+ iset_clear(s);
+ if (s->flat) {
+ hv_clear(s->flat);
+ IF_REMOVE_DEBUG(warn("iset_clear(%x): cleared", s));
+ }
+
void
DESTROY(self)
SV* self
@@ -436,8 +611,11 @@
CODE:
ISET* s = (ISET*) SvIV(SvRV(self));
- IF_DEBUG(warn("aargh!\n"));
+ IF_DEBUG(warn("aargh!\n"));
iset_clear(s);
+ if (s->flat) {
+ hv_undef(s->flat);
+ }
Safefree(s);
/* Here are some functions from Scalar::Util; they are so simple,
@@ -653,6 +831,7 @@
s->elems = 0;
s->bucket = 0;
s->buckets = 0;
+ s->flat = 0;
if (!SvROK(obj)) {
Perl_croak(aTHX_ "Set::Object::STORABLE_thaw passed a non-reference");
@@ -662,6 +841,8 @@
freezing closures, and back-references to
overloaded objects. One day I might even
understand why :-)
+
+ Bug in Storable... that's why. old news.
*/
isv = SvRV(obj);
SvIV_set(isv, (IV) s);
@@ -669,7 +850,7 @@
for (item = 3; item < items; ++item)
{
- iset_insert_one(s, ST(item));
+ ISET_INSERT(s, ST(item));
}
IF_DEBUG(warn("set!\n"));
Modified: packages/libset-object-perl/branches/upstream/current/README
===================================================================
--- packages/libset-object-perl/branches/upstream/current/README 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/README 2005-04-05 22:40:15 UTC (rev 884)
@@ -1,54 +1,294 @@
NAME
+ Set::Object - set of objects and strings
- Set::Object
+SYNOPSIS
+ use Set::Object;
+ $set = Set::Object->new();
+ $set->insert(@thingies);
+ $set->remove(@thingies);
+
+ @items = $set->elements;
+
+ $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.
- This module implements a Set of objects, that is, a collection of
- objects without duplications. It is similar to a Smalltalk
- IdentitySet.
+ The term *objects* is applied loosely - for the sake of Set::Object,
+ anything that is a reference is considered an object.
-SYNOPSIS
+ 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.
- use Set::Object;
- $simpsons = Set::Object->new($homer, $marge, $lisa);
- $simpsons->insert($bart, $lisa, $maggie); # only one $lisa
- $simpsons->remove($bart, $burns); # $burns not there; ok
- foreach $member ($simpsons->members) { ... }
- # etc
+CLASS METHODS
+ new( [*list*] )
+ Return a new "Set::Object" containing the elements passed in *list*.
-INSTALLATION
+INSTANCE METHODS
+ insert( [*list*] )
+ Add items to the "Set::Object".
- perl Makefile.PL
- make
- make test
- make install (If all tests pass)
+ Adding the same object several times is not an error, but any
+ "Set::Object" will contain at most one occurence of the same object.
-REQUIREMENTS
+ Returns the number of elements that were actually added.
- perl 5.004 or later
- a C compiler
+ 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.
- This module was developed on MS Windows NT 4.0 using MS Visual C++
- 5.0 with Service Pack 2. It was also tested on AIX 4.1.5 using
- IBM's xlc compiler.
+ 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.
-LICENSE
+ members
+ elements
+ Return the objects contained in the "Set::Object" in random (hash)
+ order.
- Copyright (c) 1998, 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
+ size
+ Return the number of elements in the "Set::Object".
-SUPPORT
+ remove( [*list*] )
+ delete( [*list*] )
+ Remove objects from a "Set::Object".
- email me or post in comp.lang.perl.modules
+ 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>
- Jean-Louis Leroy, jll at skynet.be
+ Crack-fueled enhancements courtesy of Sam Vilain, <samv at cpan.org>
- Currently maintained by Sam Vilain, sam at vilain.net
+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
-DO YOU WANT TO KNOW MORE?
+ Portions Copyright (c) 2003 - 2005, Sam Vilain. Same license.
- See the pod embedded in module.
+SEE ALSO
+ perl(1), perltie(1), Set::Scalar, overload.pm
+
Modified: packages/libset-object-perl/branches/upstream/current/lib/Set/Object.pm
===================================================================
--- packages/libset-object-perl/branches/upstream/current/lib/Set/Object.pm 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/lib/Set/Object.pm 2005-04-05 22:40:15 UTC (rev 884)
@@ -1,55 +1,137 @@
=head1 NAME
-Set::Object - set of objects
+Set::Object - set of objects and strings
=head1 SYNOPSIS
use Set::Object;
- $set = Set::Object->new();
+ my $set = set(); # or Set::Object->new()
+
+ $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);
+ }
+ }
+
=head1 DESCRIPTION
This modules implements a set of objects, that is, an unordered
collection of objects without duplication.
+The term I<objects> is applied loosely - for the sake of
+L<Set::Object>, anything that is a reference is considered an object.
+
+L<Set::Object> 1.09 and later includes support for inserting scalars
+(including the empty string, but excluding C<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.
+
=head1 CLASS METHODS
=head2 new( [I<list>] )
Return a new C<Set::Object> containing the elements passed in I<list>.
-The elements must be objects.
=head1 INSTANCE METHODS
=head2 insert( [I<list>] )
-Add objects to the C<Set::Object>.
-Adding the same object several times is not an error,
-but any C<Set::Object> will contain at most one occurence of the
-same object.
+Add items to the C<Set::Object>.
+
+Adding the same object several times is not an error, but any
+C<Set::Object> will contain at most one occurence of the same object.
+
Returns the number of elements that were actually added.
=head2 includes( [I<list>] )
-Return C<true> if all the objects in I<list> are members of the C<Set::Object>.
-I<list> may be empty, in which case C<true> is returned.
+=head2 has( [I<list>] )
+=head2 contains( [I<list>] )
+
+Return C<true> if B<all> the objects in I<list> are members of the
+C<Set::Object>. I<list> may be empty, in which case C<true> is
+always returned.
+
+=head2 member( [I<item>] )
+
+=head2 element( [I<item>] )
+
+Like C<includes>, but takes a single item to check and returns that
+item if the value is found, rather than just a true value.
+
=head2 members
-Return the objects contained in the C<Set::Object>.
+=head2 elements
+Return the objects contained in the C<Set::Object> in random (hash)
+order.
+
=head2 size
Return the number of elements in the C<Set::Object>.
=head2 remove( [I<list>] )
+=head2 delete( [I<list>] )
+
Remove objects from a C<Set::Object>.
-Removing the same object more than once, or removing an object
-absent from the C<Set::Object> is not an error.
+
+Removing the same object more than once, or removing an object absent
+from the C<Set::Object> is not an error.
+
Returns the number of elements that were actually removed.
+=head2 invert( [I<list>] )
+
+For each item in I<list>, it either removes it or adds it to the set,
+so that a change is always made.
+
+Also available as the overloaded operator C</>, 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.
+
=head2 clear
Empty this C<Set::Object>.
@@ -61,36 +143,84 @@
=head2 intersection( [I<list>] )
-Return a new C<Set::Object> containing the intersection of the
+Return a new C<Set::Object> containing the intersection of the
C<Set::Object>s passed as arguments.
-Also available as overloaded operator *.
+Also available as overloaded operator C<*>.
+
=head2 union( [I<list>] )
-Return a new C<Set::Object> containing the union of the
+Return a new C<Set::Object> containing the union of the
C<Set::Object>s passed as arguments.
-Also available as overloaded operator +.
+Also available as overloaded operator C<+>.
+
+=head2 difference ( I<set> )
+
+Return a new C<Set::Object> containing the members of the first
+(invocant) set with the passed C<Set::Object>s' elements removed.
+
+Also available as overloaded operator C<->.
+
+=head2 unique ( I<set> )
+
+=head2 symmetric_difference ( I<set> )
+
+Return a new C<Set::Object> containing the members of all passed sets
+(including the invocant), with common elements removed. This will be
+the opposite (complement) of the I<intersection> of the two sets.
+
+Also available as overloaded operator C<%>.
+
=head2 subset( I<set> )
Return C<true> if this C<Set::Object> is a subset of I<set>.
-Also available as operator <=.
+Also available as operator C<E<lt>=>.
+
=head2 proper_subset( I<set> )
Return C<true> if this C<Set::Object> is a proper subset of I<set>
-Also available as operator <.
+Also available as operator C<E<lt>>.
=head2 superset( I<set> )
Return C<true> if this C<Set::Object> is a superset of I<set>.
-Also available as operator >=.
+Also available as operator C<E<gt>=>.
=head2 proper_superset( I<set> )
Return C<true> if this C<Set::Object> is a proper superset of I<set>
-Also available as operator >.
+Also available as operator C<E<gt>>.
+=head1 Set::Scalar compatibility methods
+
+By and large, L<Set::Object> is not and probably never will be
+feature-compatible with L<Set::Scalar>; however the following
+functions are provided anyway.
+
+=head2 compare( I<set> )
+
+returns one of:
+
+ "proper intersect"
+ "proper subset"
+ "proper superset"
+ "equal"
+ "disjoint"
+
+=head2 is_disjoint( I<set> )
+
+Returns a true value if the two sets have no common items.
+
+=head2 as_string_callback( I<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.
+
+
+
=head1 FUNCTIONS
The following functions are defined by the Set::Object XS code for
@@ -98,6 +228,9 @@
Scalar::Util module, but there are a couple that provide functions not
catered to by that module.
+Please use the versions in L<Scalar::Util> in preference to these
+functions.
+
=over
=item B<blessed>
@@ -136,7 +269,7 @@
This function returns true, if the value it is passed looks like it
I<already is> a representation of an I<integer>. This is so that you
can decide whether the value passed is a hash key or an array
-index... <devious grin>.
+index.
=item B<is_key>
@@ -145,28 +278,18 @@
But wait, you say - Set::Object has no indices, one of the fundamental
properties of a Set is that it is an I<unordered collection>. Which
-means I<no indices>. Stay tuned for the answer.
+means I<no indices>. Well, if this module were ever to be derived to
+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.
=back
-=head1 INSTALLATION
-
-This module is partly written in C, so you'll need a C compiler to
-install it. Use the familiar sequence:
-
- perl Makefile.PL
- make
- make test
- make install
-
-This module was developed on Windows NT 4.0, using the Visual C++
-compiler with Service Pack 2. It was also tested on AIX using IBM's
-xlc compiler.
-
=head1 PERFORMANCE
The following benchmark compares C<Set::Object> with using a hash to
-emulate a set-like collection:
+emulate a set-like collection (this is an old benchmark, but still
+holds true):
use Set::Object;
@@ -209,19 +332,20 @@
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>
+
=head1 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, Sam Vilain. 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.
=head1 SEE ALSO
-perl(1), perltie(1), overload.pm
+perl(1), perltie(1), L<Set::Scalar>, overload.pm
=cut
@@ -240,21 +364,26 @@
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
+ at EXPORT = qw(set);
@EXPORT_OK = qw( ish_int is_int is_string is_double blessed reftype
refaddr is_overloaded is_object is_key );
-$VERSION = '1.08';
+$VERSION = '1.10';
bootstrap Set::Object $VERSION;
# Preloaded methods go here.
+our $cust_disp;
+
sub as_string
{
+ return $cust_disp->(@_) if $cust_disp;
my $self = shift;
croak "Tried to use as_string on something other than a Set::Object"
unless (UNIVERSAL::isa($self, __PACKAGE__));
- 'Set::Object(' . (join ' ', $self->members) . ')'
+ 'Set::Object(' . (join ' ', sort { $a cmp $b }
+ $self->members) . ')'
}
sub equal
@@ -272,18 +401,28 @@
sub union
{
- Set::Object->new( map { $_->members() }
- grep { UNIVERSAL::isa($_, __PACKAGE__) }
- @_ )
+ Set::Object->new
+ ( map { $_->members() }
+ grep { UNIVERSAL::isa($_, __PACKAGE__) }
+ @_ );
}
sub op_union
{
+ my $self = shift;
+ my $other;
+ if (ref $_[0]) {
+ $other = shift;
+ } else {
+ $other = __PACKAGE__->new(shift);
+ }
+
croak("Tried to form union between Set::Object & "
- .(ref($_[1])||$_[1]))
- unless UNIVERSAL::isa($_[1], __PACKAGE__);
+ ."`$other'")
+ if ref $other and not UNIVERSAL::isa($other, __PACKAGE__);
- Set::Object->new( shift->members(), shift->members() )
+ $self->union($other);
+
}
sub intersection
@@ -291,37 +430,101 @@
my $s = shift;
return Set::Object->new() unless $s;
- my @r = $s->members;
+ my $rem = __PACKAGE__->new($s->members);
- while (@r && ($s = shift))
+ while ($s = shift)
{
+ if (!ref $s) {
+ $s = __PACKAGE__->new($s);
+ }
+
croak("Tried to form intersection between Set::Object & "
.(ref($s)||$s)) unless UNIVERSAL::isa($s, __PACKAGE__);
- @r = grep { $s->includes( $_ ) } @r;
+ $rem->remove(grep { !$s->includes($_) } $rem->members);
}
- Set::Object->new( @r );
+ $rem;
}
sub op_intersection
{
- goto &intersection;
+ my $s1 = shift;
+ my $s2;
+ if (ref $_[0]) {
+ $s2 = shift;
+ } else {
+ $s2 = __PACKAGE__->new(shift);
+ }
+ my $r = shift;
+ if ( $r ) {
+ return intersection($s2, $s1);
+ } else {
+ return intersection($s1, $s2);
+ }
+
}
sub difference
{
my ($s1, $s2, $r) = @_;
+ if ( ! ref $s2 ) {
+ if ( is_int($s2) and !is_string($s2) and $s2 == 0 ) {
+ return __PACKAGE__->new();
+ } else {
+ my $set = __PACKAGE__->new($s2);
+ $s2 = $set;
+ }
+ }
croak("Tried to find difference between Set::Object & "
.(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__);
- # this version has been known to segfault, if you comment out this line:
- Set::Object->new( grep { !$s2->includes($_) } $s1->members );
- # and uncomment these two lines, it will probably go away:
- #my @a = grep { !$s2->includes($_) } $s1->members;
- #Set::Object->new( @a );
+ my $s;
+ if ( $r ) {
+ $s = Set::Object->new( grep { !$s1->includes($_) } $s2->members );
+ } else {
+ $s = Set::Object->new( grep { !$s2->includes($_) } $s1->members );
+ }
+ $s;
}
+sub op_invert
+{
+ my $self = shift;
+ my $other;
+ if (ref $_[0]) {
+ $other = shift;
+ } else {
+ $other = __PACKAGE__->new(shift);
+ }
+
+ croak("Tried to form union between Set::Object & "
+ ."`$other'")
+ if ref $other and not UNIVERSAL::isa($other, __PACKAGE__);
+
+ my $result = Set::Object->new( $self->members() );
+ $result->invert( $other->members() );
+ return $result;
+
+}
+
+sub op_symm_diff
+{
+ my $self = shift;
+ my $other;
+ if (ref $_[0]) {
+ $other = shift;
+ } else {
+ $other = __PACKAGE__->new(shift);
+ }
+ return $self->symmetric_difference($other);
+}
+
+sub unique {
+ my $self = shift;
+ $self->symmetric_difference(@_);
+}
+
sub symmetric_difference
{
my ($s1, $s2) = @_;
@@ -369,16 +572,182 @@
'""' => \&as_string,
'+' => \&op_union,
'*' => \&op_intersection,
- '%' => \&symmetric_difference,
+ '%' => \&op_symm_diff,
+ '/' => \&op_invert,
'-' => \&difference,
'==' => \&equal,
'!=' => \¬_equal,
'<' => \&proper_subset,
'>' => \&proper_superset,
'<=' => \&subset,
- '>=' => \&superset
+ '>=' => \&superset,
+ '%{}' => sub { my $self = shift;
+ my %h = {};
+ tie %h, $self->tie_hash_pkg, [], $self;
+ \%h },
+ '@{}' => sub { my $self = shift;
+ my @h = {};
+ tie @h, $self->tie_array_pkg, [], $self;
+ \@h },
+ 'bool' => sub { 1 },
+ fallback => 1,
;
+sub tie_hash_pkg { "Set::Object::TieHash" };
+sub tie_array_pkg { "Set::Object::TieArray" };
+
+{ package Set::Object::TieArray;
+ sub TIEARRAY {
+ my $p = shift;
+ my $tie = bless [ @_ ], $p;
+ require Scalar::Util;
+ Scalar::Util::weaken($tie->[0]);
+ Scalar::Util::weaken($tie->[1]);
+ return $tie;
+ }
+ sub promote {
+ my $self = shift;
+ @{$self->[0]} = sort $self->[1]->members;
+ return $self->[0];
+ }
+ sub commit {
+ my $self = shift;
+ $self->[1]->clear;
+ $self->[1]->insert(@{$self->[0]});
+ }
+ sub FETCH {
+ my $self = shift;
+ my $index = shift;
+ $self->promote->[$index];
+ }
+ sub STORE {
+ my $self = shift;
+ my $index = shift;
+ $self->promote->[$index] = shift;
+ $self->commit;
+ }
+ sub FETCHSIZE {
+ my $self = shift;
+ return $self->[1]->size;
+ }
+ sub STORESIZE {
+ my $self = shift;
+ my $count = shift;
+ $#{$self->promote}=$count-1;
+ $self->commit;
+ }
+ sub EXTEND {
+ }
+ sub EXISTS {
+ my $self = shift;
+ my $index = shift;
+ if ( $index+1 > $self->[1]->size) {
+ return undef;
+ } else {
+ return 1;
+ }
+ }
+ sub DELETE {
+ my $self = shift;
+ delete $self->promote->[(shift)];
+ $self->commit;
+ }
+ sub PUSH {
+ my $self = shift;
+ $self->[1]->insert(@_);
+ }
+ sub POP {
+ my $self = shift;
+ my $rv = pop @{$self->promote};
+ $self->commit;
+ return $rv;
+ }
+ sub CLEAR {
+ my $self = shift;
+ $self->[1]->clear;
+ }
+ sub SHIFT {
+ my $self = shift;
+ my $rv = shift @{$self->promote};
+ $self->commit;
+ return $rv;
+ }
+ sub UNSHIFT {
+ my $self = shift;
+ $self->[1]->insert(@_);
+ }
+ sub SPLICE {
+ my $self = shift;
+ my @rv;
+ # perl5--
+ if ( @_ == 1 ) {
+ splice @{$self->promote}, $_[0];
+ }
+ elsif ( @_ == 2 ) {
+ splice @{$self->promote}, $_[0], $_[1];
+ }
+ else {
+ splice @{$self->promote}, $_[0], $_[1], @_;
+ }
+ $self->commit;
+ @rv;
+ }
+}
+
+{ package Set::Object::TieHash;
+ sub TIEHASH {
+ my $p = shift;
+ my $tie = bless [ @_ ], $p;
+ require Scalar::Util;
+ Scalar::Util::weaken($tie->[0]);
+ Scalar::Util::weaken($tie->[1]);
+ return $tie;
+ }
+ sub FETCH {
+ my $self = shift;
+ return $self->[1]->includes(shift);
+ }
+ sub STORE {
+ my $self = shift;
+ my $item = shift;
+ if ( shift ) {
+ $self->[1]->insert($item);
+ } else {
+ $self->[1]->remove($item);
+ }
+ }
+ sub DELETE {
+ my $self = shift;
+ my $item = shift;
+ $self->[1]->remove($item);
+ }
+ sub CLEAR {
+ my $self = shift;
+ $self->[1]->clear;
+ }
+ sub EXISTS {
+ my $self = shift;
+ $self->[1]->includes(shift);
+ }
+ sub FIRSTKEY {
+ my $self = shift;
+ @{$self->[0]} = $self->[1]->members;
+ $self->NEXTKEY;
+ }
+ sub NEXTKEY {
+ my $self = shift;
+ if ( @{$self->[0]} ) {
+ return (shift @{$self->[0]});
+ } else {
+ return ();
+ }
+ }
+ sub SCALAR {
+ my $self = shift;
+ $self->[1]->size;
+ }
+}
+
# Autoload methods go after =cut, and are processed by the autosplit program.
# This function is used to differentiate between an integer and a
# string for use by the hash container types
@@ -451,6 +820,99 @@
goto &_STORABLE_thaw;
#print "Got here\n";
}
+
+sub delete {
+ my $self = shift;
+ return $self->remove(@_);
+}
+
+our $AUTOLOAD;
+sub AUTOLOAD {
+ croak "No such method $AUTOLOAD";
+}
+
+sub invert {
+ my $self = shift;
+ while ( @_ ) {
+ my $sv = shift;
+ defined $sv or next;
+ if ( $self->includes($sv) ) {
+ $self->remove($sv);
+ } else {
+ $self->insert($sv);
+ }
+ }
+}
+
+sub compare {
+ my $self = shift;
+ my $other = shift;
+
+ return "apples, oranges" unless UNIVERSAL::isa($other, __PACKAGE__);
+
+ my $only_self = $self - $other;
+ my $only_other = $other - $self;
+ my $intersect = $self * $other;
+
+ if ( $intersect->size ) {
+ if ( $only_self->size ) {
+ if ( $only_other->size ) {
+ return "proper intersect";
+ } else {
+ return "proper subset";
+ }
+ } else {
+ if ( $only_other->size ) {
+ return "proper superset";
+ } else {
+ return "equal";
+ }
+ }
+ } else {
+ return "disjoint";
+ }
+}
+
+sub is_disjoint {
+ my $self = shift;
+ my $other = shift;
+
+ return "apples, oranges" unless UNIVERSAL::isa($other, __PACKAGE__);
+ return !($self*$other)->size;
+}
+
+use Data::Dumper;
+sub as_string_callback {
+ shift;
+ if ( @_ ) {
+ $cust_disp = shift;
+ if ( $cust_disp &&
+ $cust_disp == \&as_string ) {
+ undef($cust_disp);
+ }
+ } else {
+ \&as_string;
+ }
+}
+
+sub elements {
+ my $self = shift;
+ return $self->members(@_);
+}
+
+sub has { (shift)->includes(@_) }
+sub contains { (shift)->includes(@_) }
+sub element { (shift)->member(@_) }
+sub member {
+ my $self = shift;
+ my $item = shift;
+ return ( $self->includes($item) ?
+ $item : undef );
+}
+
+sub set {
+ __PACKAGE__->new(@_);
+}
1;
__END__
Added: packages/libset-object-perl/branches/upstream/current/t/ingy/arrayref.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/ingy/arrayref.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/ingy/arrayref.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,37 @@
+# -*- perl -*-
+
+use Set::Object;
+use Test::More tests => 15;
+
+my $bob = bless {}, "Bob";
+my $bert = bless {}, "Bert";
+
+my $set = set(0, 1, 2, 3, $bob);
+
+isa_ok($set, "Set::Object", "set()");
+
+is(@$set, 5, "scalar list context");
+push @$set, 13;
+ok($set->includes(13), "tied array PUSH");
+unshift @$set, 17;
+ok($set->includes(17), "tied array UNSHIFT");
+
+is(@$set, 7, "size right");
+is(shift(@$set), 0, "shift off in right order");
+is(pop(@$set), $bob, "pop off in right order");
+is(@$set, 5, "size still right");
+$#$set = 1;
+is($set->size, 2, "array STORESIZE");
+$set->[0] = 17;
+ok($set->includes(17), "array STORE");
+is($set->size, 2, "array STORE doesn't increase size");
+ok(!exists $set->[2], "array EXISTS");
+is($set->size, 2, "array EXISTS didn't increase size");
+delete($set->[1]);
+is($set->size, 1, "array DELETE");
+
+$set = set( 1..9 );
+splice @$set, 0, 2;
+is_deeply([@$set], [3..9], "splice (and list context)");
+
+
Modified: packages/libset-object-perl/branches/upstream/current/t/object/Person.pm
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/Person.pm 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/Person.pm 2005-04-05 22:40:15 UTC (rev 884)
@@ -12,6 +12,8 @@
++$n;
my $type = shift;
my $self = bless { @_ }, $type;
+ $self->{firstname} ||= "";
+ $self->{name} ||= "";
return $self;
}
Modified: packages/libset-object-perl/branches/upstream/current/t/object/abuse.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/abuse.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/abuse.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -1,7 +1,7 @@
#!/usr/bin/perl -w
use strict;
-use Test::More tests => 21;
+use Test::More tests => 20;
use Set::Object;
my @objects = ( bless([], "Bob"),
@@ -23,8 +23,9 @@
ok(( $set->union([ "carborettor" ]) == $set), "union method");
-eval{ my $x = $set + "carborettor" };
-like($@, qr/Tried to form union.*carborettor/, "+ operator");
+# no longer abuse...
+#eval{ my $x = $set + "carborettor" };
+#like($@, qr/Tried to form union.*carborettor/, "+ operator");
eval { my $x = $set * [ "octarine" ] };
like($@, qr/Tried to .*intersection.*ARRAY/, "* operator");
Modified: packages/libset-object-perl/branches/upstream/current/t/object/clear.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/clear.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/clear.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -1,6 +1,6 @@
use Set::Object;
-require 't/Person.pm';
+require 't/object/Person.pm';
package Person;
populate();
Modified: packages/libset-object-perl/branches/upstream/current/t/object/difference.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/difference.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/difference.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -1,6 +1,6 @@
use Set::Object;
-require 't/Person.pm';
+require 't/object/Person.pm';
package Person;
populate();
Modified: packages/libset-object-perl/branches/upstream/current/t/object/equal.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/equal.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/equal.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -1,6 +1,6 @@
use Set::Object;
-require 't/Person.pm';
+require 't/object/Person.pm';
package Person;
populate();
Modified: packages/libset-object-perl/branches/upstream/current/t/object/flags.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/flags.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/flags.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -8,8 +8,8 @@
use Set::Object;
-require 't/Person.pm';
-require 't/Saint.pm';
+require 't/object/Person.pm';
+require 't/object/Saint.pm';
print "1..2\n";
Modified: packages/libset-object-perl/branches/upstream/current/t/object/includes.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/includes.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/includes.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -2,7 +2,7 @@
use Set::Object;
-require 't/Person.pm';
+require 't/object/Person.pm';
package Person;
use Test::More tests => 7;
Modified: packages/libset-object-perl/branches/upstream/current/t/object/insert.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/insert.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/insert.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -2,7 +2,7 @@
use Set::Object;
-require 't/Person.pm';
+require 't/object/Person.pm';
package Person;
use Test::More tests => 18;
@@ -28,21 +28,25 @@
is($simpsons->size(), 5, "Set::Object->size() [ lots of inserts ]");
# Now be really abusive
-eval { $simpsons->insert("bogon") };
-like($@, qr/Tried to insert/i, "Caught feeding in a bogon OK");
+#eval { $simpsons->insert("bogon") };
+#like($@, qr/Tried to insert/i, "Caught feeding in a bogon OK");
+#
my $test = new Set::Object;
eval { $test->insert("bogon"); };
-is ( $test."", "Set::Object()", "as_string on bogon-ified set");
+is ( $test."", "Set::Object(bogon)", "as_string on bogon-ified set");
+eval { $simpsons->remove("bogon"); };
+
# array refs
my $array;
$test->insert($array = [ "array", "ref" ]);
my $array2 = [ "array", "ref" ];
$test->insert($array);
-is ($test->size(), 1, "Inserted an array OK");
+is ($test->size(), 2, "Inserted an array OK");
ok ($test->includes($array), "Can put non-objects in a set");
+ok ($test->includes("bogon"), "Can put scalars in a set");
ok (!$test->includes($array2), "Lookup of identical item doesn't work");
like ( $test."", qr/Set::Object\(ARRAY/, "Inserted an array OK");
Modified: packages/libset-object-perl/branches/upstream/current/t/object/intersection.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/intersection.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/intersection.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -1,6 +1,6 @@
use Set::Object;
-require 't/Person.pm';
+require 't/object/Person.pm';
package Person;
populate();
@@ -31,3 +31,6 @@
print 'not ' unless ($kids * Set::Object->new())->size == 0;
print "ok 6\n";
+
+print "# size = ".($kids * Set::Object->new())->size."\n";
+
Modified: packages/libset-object-perl/branches/upstream/current/t/object/members.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/members.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/members.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -1,6 +1,6 @@
use Set::Object;
-require 't/Person.pm';
+require 't/object/Person.pm';
package Person;
populate();
Modified: packages/libset-object-perl/branches/upstream/current/t/object/refcount.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/refcount.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/refcount.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -1,6 +1,6 @@
use Set::Object;
-require 't/Person.pm';
+require 't/object/Person.pm';
package Person;
print "1..9\n";
Modified: packages/libset-object-perl/branches/upstream/current/t/object/remove.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/remove.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/remove.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -1,6 +1,6 @@
use Set::Object;
-require 't/Person.pm';
+require 't/object/Person.pm';
package Person;
populate();
Modified: packages/libset-object-perl/branches/upstream/current/t/object/subsuper.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/subsuper.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/subsuper.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -1,6 +1,6 @@
use Set::Object;
-require 't/Person.pm';
+require 't/object/Person.pm';
package Person;
populate();
Modified: packages/libset-object-perl/branches/upstream/current/t/object/symmetric_difference.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/symmetric_difference.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/symmetric_difference.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -1,6 +1,6 @@
use Set::Object;
-require 't/Person.pm';
+require 't/object/Person.pm';
package Person;
populate();
Modified: packages/libset-object-perl/branches/upstream/current/t/object/union.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/object/union.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/object/union.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -1,6 +1,6 @@
use Set::Object;
-require 't/Person.pm';
+require 't/object/Person.pm';
package Person;
populate();
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/basic.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/basic.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/basic.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,57 @@
+
+use Set::Object;
+use Test::More tests => 24;
+
+use strict;
+
+my $s = Set::Object->new;
+
+is($s->size, 0, "new set size is 0");
+ok($s->is_null, "->is_null()");
+is($s, "Set::Object()", "stringify");
+
+$s->insert("a");
+
+is($s->size, 1, "->size() [scalar]");
+ok(!$s->is_null, "->is_null() [scalar]");
+is($s, "Set::Object(a)", "stringify");
+
+$s->insert("a");
+
+is($s->size, 1, "->size() [scalar]");
+ok(!$s->is_null, "->is_null() [scalar]");
+is($s, "Set::Object(a)", "stringify");
+
+$s->insert("b", "c", "d", "e");
+
+is($s->size, 5, "->size() [scalar]");
+ok(!$s->is_null, "->is_null() [scalar]");
+is($s, "Set::Object(a b c d e)", "stringify");
+
+$s->delete("b", "d");
+
+is($s->size, 3, "->size() [scalar]");
+ok(!$s->is_null, "->is_null() [scalar]");
+is($s, "Set::Object(a c e)", "stringify");
+
+$s->invert("b", "c", "d");
+
+is($s->size, 4, "->size() [scalar]");
+ok(!$s->is_null, "->is_null() [scalar]");
+is($s, "Set::Object(a b d e)", "stringify");
+
+$s->clear();
+
+is($s->size, 0, "->size() [scalar]");
+ok($s->is_null, "->is_null() [scalar]");
+is($s, "Set::Object()", "stringify");
+
+# End Of File.
+
+$s->invert("b", "c", "d");
+
+is($s->size, 3, "->size() [scalar]");
+ok(!$s->is_null, "->is_null() [scalar]");
+is($s, "Set::Object(b c d)", "stringify");
+
+
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/basic_overload.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/basic_overload.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/basic_overload.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,49 @@
+
+use Set::Object;
+
+use Test::More tests => 18;
+
+use strict;
+
+my $s = Set::Object->new;
+
+is($s->size, 0, "new set size is 0");
+ok($s->is_null, "->is_null()");
+is($s, "Set::Object()", "stringify");
+
+$s += "a";
+
+is($s->size, 1, "->size()");
+ok(!$s->is_null, "->is_null()");
+is($s, "Set::Object(a)", "stringify");
+
+$s += "a";
+
+is($s->size, 1, "->size()");
+ok(!$s->is_null, "->is_null()");
+is($s, "Set::Object(a)", "stringify");
+
+$s += "b";
+$s += "c";
+$s += "d";
+$s += "e";
+
+is($s->size, 5, "->size()");
+ok(!$s->is_null, "->is_null()");
+is($s, "Set::Object(a b c d e)", "stringify");
+
+$s -= "b";
+$s -= "d";
+
+is($s->size, 3, "->size()");
+ok(!$s->is_null, "->is_null()");
+is($s, "Set::Object(a c e)", "stringify");
+
+$s /= "b";
+$s /= "c";
+$s /= "d";
+
+is($s->size, 4, "->size()");
+ok(!$s->is_null, "->is_null()");
+is($s, "Set::Object(a b d e)", "stringify");
+
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/boolean.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/boolean.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/boolean.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,17 @@
+
+use Set::Object;
+print "1..2\n";
+
+my @a = qw(One Two Three);
+my @b = qw(Four Five Six);
+
+my $ssa = Set::Object->new(@a);
+my $ssb = Set::Object->new(@b);
+
+print "not " unless $ssa;
+print "ok 1\n";
+
+my $is = $ssa->intersection($ssb);
+print "not " if $is->size;
+print "ok 2 - $is\n";
+
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/clear.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/clear.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/clear.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,10 @@
+use Set::Object;
+print "1..1\n";
+
+my $s = Set::Object->new(0..99);
+
+$s->clear;
+
+print "not " unless $s->is_null;
+print "ok 1\n";
+
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/compare.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/compare.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/compare.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,96 @@
+
+use Set::Object;
+use strict;
+
+my $t = Set::Object->new(qw(a b c));
+my $u = Set::Object->new(qw(a b c));
+my $v = Set::Object->new(qw(d e f));
+my $w = Set::Object->new(qw(a b));
+my $x = Set::Object->new(qw(b c d));
+my $n = Set::Object->new(qw());
+my $o = Set::Object->new(qw());
+
+print "1..23\n";
+
+print "not " unless $t == $u;
+print "ok 1\n";
+
+print "not " unless $t != $v;
+print "ok 2\n";
+
+print "not " if $t == $v;
+print "ok 3\n";
+
+print "not " if $t == $w;
+print "ok 4\n";
+
+print "not " unless $t > $w;
+print "ok 5\n";
+
+print "not " unless $w < $t;
+print "ok 6\n";
+
+print "not " unless $t >= $u;
+print "ok 7\n";
+
+print "not " unless $t <= $u;
+print "ok 8\n";
+
+print "not " unless $t >= $w;
+print "ok 9\n";
+
+print "not " unless $w <= $t;
+print "ok 10\n";
+
+print "not " unless $t eq "Set::Object(a b c)";
+print "ok 11\n";
+
+print "not " unless "Set::Object(a b c)" eq $u;
+print "ok 12\n";
+
+print "not " unless $t->compare($x) eq 'proper intersect';
+print "ok 13\n";
+
+print "not " unless $t->compare($v) eq 'disjoint';
+print "ok 14\n";
+
+print "not " unless $t > $n;
+print "ok 15\n";
+
+print "not " unless $n < $t;
+print "ok 16\n";
+
+print "not " unless $n == $o;
+print "ok 17\n";
+
+print "not " unless $o == $n;
+print "ok 18\n";
+
+print "not " if $n < $o;
+print "ok 19\n";
+
+print "not " if $n > $o;
+print "ok 20\n";
+
+print "not " unless $n <= $o;
+print "ok 21\n";
+
+print "not " unless $n >= $o;
+print "ok 22\n";
+
+# [cpan #5829] d
+{
+ my @d = $t->is_disjoint($v) ;
+ print "not " unless @d == 1 && $d[0];
+ print "ok 23\n";
+}
+
+sub show {
+ my $z = shift;
+
+ print "# set: ".sprintf("SV = %x, addr = %x", Set::Object::refaddr($z), $$z)."\b";
+ print "# size is: ",($z->size),"\n";
+ print "# stringified: $z\n";
+ print "# universe is: ",($z->universe),"\n";
+}
+
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/custom_display.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/custom_display.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/custom_display.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,38 @@
+
+use Set::Object;
+print "1..7\n";
+
+$a = Set::Object->new("a".."e");
+$b = Set::Object->new("a".."e");
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 1 # $a\n";
+
+my $cb = Set::Object->as_string_callback;
+
+Set::Object->as_string_callback(sub{join(",",sort shift->elements)});
+
+print "not " unless $a eq "a,b,c,d,e";
+print "ok 2 # $a\n";
+
+$b->as_string_callback(sub{join("-",sort shift->elements)});
+
+print "not " unless $b eq "a-b-c-d-e";
+print "ok 3 # $b\n";
+
+#print "not " unless $a eq "a,b,c,d,e";
+print "ok 4 # Skip misplaced functionality\n";
+
+Set::Object->as_string_callback($cb);
+
+print "not " unless "$a" eq "Set::Object(a b c d e)";
+print "ok 5 # $a\n";
+
+#print "not " unless $b eq "a-b-c-d-e";
+print "ok 6 # Skip misplaced functionality\n";
+
+$b->as_string_callback(undef);
+
+print "not " unless $b eq "Set::Object(a b c d e)";
+print "ok 7 # $b\n";
+
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/difference.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/difference.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/difference.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,84 @@
+
+use Set::Object;
+print "1..28\n";
+
+sub check {
+ my ($test, $ok) = @_;
+ if ($ok) {
+ print "ok $test\n";
+ } else {
+ print "not ok $test\n";
+ }
+}
+
+my $a = Set::Object->new("a".."e");
+my $b = Set::Object->new("c".."g");
+
+my $d = $a->difference($b);
+
+check( 1, $d eq "Set::Object(a b)" );
+check( 2, $a eq "Set::Object(a b c d e)" );
+check( 3, $b eq "Set::Object(c d e f g)" );
+
+my $e = $a - $b;
+
+check( 4, $e eq "Set::Object(a b)" );
+check( 5, $a eq "Set::Object(a b c d e)" );
+check( 6, $b eq "Set::Object(c d e f g)" );
+
+my $f = $b->difference($a);
+
+check( 7, $f eq "Set::Object(f g)" );
+check( 8, $a eq "Set::Object(a b c d e)" );
+check( 9, $b eq "Set::Object(c d e f g)" );
+
+my $g = $b - $a;
+
+check( 10, $g eq "Set::Object(f g)" );
+check( 11, $a eq "Set::Object(a b c d e)" );
+check( 12, $b eq "Set::Object(c d e f g)" );
+
+my $h = $a - "x";
+
+check( 13, $h eq "Set::Object(a b c d e)" );
+check( 14, $a eq "Set::Object(a b c d e)" );
+
+my $i = "y" - $a;
+
+check( 15, $i eq "Set::Object(y)" );
+check( 16, $a eq "Set::Object(a b c d e)" );
+
+my $j = $a - "c";
+
+check( 17, $j eq "Set::Object(a b d e)" );
+check( 18, $a eq "Set::Object(a b c d e)" );
+
+my $k = "e" - $a;
+
+check( 19, $k eq "Set::Object()" );
+check( 20, $a eq "Set::Object(a b c d e)" );
+
+my $m = Set::Object->new();
+my $n = Set::Object->new();
+my $o = $m - $n;
+
+check( 21, defined($m) && ref($m) && $m->isa("Set::Object") );
+check( 22, defined($n) && ref($n) && $n->isa("Set::Object") );
+
+check( 23, $m eq $n );
+check( 24, $n eq $o );
+check( 25, $o eq $m );
+check( 26, $m == $n );
+check( 27, $n == $o );
+check( 28, $o == $m );
+
+
+sub show {
+ my $z = shift;
+
+ print "# set: ".sprintf("SV = %x, addr = %x", Set::Object::refaddr($z), $$z)."\b";
+ print "# size is: ",($z->size),"\n";
+ print "# stringified: $z\n";
+ print "# universe is: ",($z->universe),"\n";
+}
+
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/each.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/each.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/each.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,32 @@
+use Test::More skip_all => "TO-DO";
+
+
+
+print "1..2\n";
+
+my @a = ("a".."e",0);
+my $a = Set::Object->new(@a);
+
+my $e;
+my %e;
+
+while (defined($e = $a->each)) {
+ print "# e = $e\n";
+ $e{$e}++;
+}
+
+print "not " if defined $e;
+print "ok 1\n";
+
+my $n;
+
+for my $e (@a) {
+ $n++ if exists $e{$e} && $e{$e} == 1;
+}
+
+print "not " unless $n == @a && keys %e == @a;
+print "ok 2\n";
+
+
+
+
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/has.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/has.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/has.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,15 @@
+
+use Set::Object;
+print "1..3\n";
+
+my $s = Set::Object->new(qw(a b c 0));
+
+print "not " unless $s->has('a');
+print "ok 1\n";
+
+print "not " unless $s->contains('0');
+print "ok 2\n";
+
+print "not " if $s->has('1');
+print "ok 3\n";
+
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/intersection.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/intersection.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/intersection.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,88 @@
+
+use Set::Object;
+print "1..20\n";
+
+my $a = Set::Object->new("a".."e");
+my $b = Set::Object->new("c".."g");
+
+my $d = $a->intersection($b);
+
+Set::Object->as_string_callback(sub { my $self = shift; "(".join(" ", sort $self->members).")" });
+
+print "not " unless $d eq "(c d e)";
+print "ok 1\n";
+
+print "not " unless $a eq "(a b c d e)";
+print "ok 2\n";
+
+print "not " unless $b eq "(c d e f g)";
+print "ok 3\n";
+
+my $e = $a * $b;
+
+print "not " unless $e eq "(c d e)";
+print "ok 4\n";
+
+print "not " unless $a eq "(a b c d e)";
+print "ok 5\n";
+
+print "not " unless $b eq "(c d e f g)";
+print "ok 6\n";
+
+my $f = $b->intersection($a);
+
+print "not " unless $f eq "(c d e)";
+print "ok 7\n";
+
+print "not " unless $a eq "(a b c d e)";
+print "ok 8\n";
+
+print "not " unless $b eq "(c d e f g)";
+print "ok 9\n";
+
+my $g = $b * $a;
+
+print "not " unless $g eq "(c d e)";
+print "ok 10\n";
+
+print "not " unless $a eq "(a b c d e)";
+print "ok 11\n";
+
+print "not " unless $b eq "(c d e f g)";
+print "ok 12\n";
+
+my $h = $a * "x";
+
+print "not " unless $h eq "()";
+print "ok 13\n";
+
+print "not " unless $a eq "(a b c d e)";
+print "ok 14\n";
+
+my $i = "y" * $a;
+
+print "not " unless $i eq "()";
+print "ok 15\n";
+
+print "not " unless $a eq "(a b c d e)";
+print "ok 16\n";
+
+my $j = $a * "c";
+
+print "not " unless $j eq "(c)";
+print "ok 17\n";
+
+print "not " unless $a eq "(a b c d e)";
+print "ok 18\n";
+
+my $k = "e" * $a;
+
+print "not " unless $k eq "(e)";
+print "ok 19\n";
+
+print "not " unless $a eq "(a b c d e)";
+print "ok 20\n";
+
+
+
+
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/member.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/member.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/member.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,15 @@
+use Set::Object;
+
+print "1..3\n";
+
+my $s = Set::Object->new(qw(a b c 0));
+
+print "not " unless $s->member('a') eq 'a';
+print "ok 1\n";
+
+print "not " unless $s->element('0') eq '0';
+print "ok 2\n";
+
+print "not " if defined $s->member('1');
+print "ok 3\n";
+
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/misc.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/misc.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/misc.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,25 @@
+use Set::Object;
+
+print "1..2\n";
+
+{
+ # Malcolm Purvis <malcolm.purvis at alcatel.com.au>
+ my $s1 = Set::Object->new("A");
+ my $s1_again = Set::Object->new("A");
+ my $s2 = $s1->union($s1_again);
+ my $s3 = Set::Object->new("C");
+ my $s4 = $s2->difference($s3);
+ print "not " unless $s4 eq "Set::Object(A)";
+ print "ok 1\n";
+}
+
+{
+ # Malcolm Purvis <malcolm.purvis at alcatel.com.au>
+ my $s1 = Set::Object->new(("A", "B"));
+ my $s1_again = Set::Object->new(("A", "B"));
+ my $s2 = $s1->union($s1_again);
+ my $s3 = Set::Object->new("C");
+ my $s4 = $s2->difference($s3);
+ print "not " unless $s4 eq "Set::Object(A B)";
+ print "ok 2\n";
+}
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/set_set.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/set_set.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/set_set.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,48 @@
+use Set::Object;
+
+print "1..2\n";
+
+my $s = Set::Object->new("a");
+my $t = Set::Object->new("b");
+
+$s->insert($t);
+
+print "not " unless $s eq "Set::Object(Set::Object(b) a)";
+print "ok 1\n";
+
+$t->insert($s);
+
+# sure, this can be infinite with Set::Object. I don't care.
+#print "not " unless $s eq "(a (b (a ...)))";
+#print "ok 2\n";
+#
+#print "not " unless $t eq "(b (a (b ...)))";
+#print "ok 3\n";
+#
+#my $u = Set::Object->new("c");
+#
+#$u->insert($u);
+#
+#print "u is $u\n";
+#print "not " unless $u == "(c (c ...))";
+#print "ok 4\n";
+#
+#$s->insert($u);
+#
+## There is some nondeterminism that needs to be resolved.
+#print "not " unless $s == "(a (b (a ...)) (c ...))" or
+ #$s == "(a (b (a (c ...) ...)) (c ...))";
+#print "ok 5\n";
+#
+#print "not " unless $t == "(b (a (b ...) (c ...)))" or
+ #$t == "(b (a (b (c ...) ...) (c ...)))";
+#print "ok 6\n";
+#
+$t->delete($s);
+#
+#print "not " unless $s == "(a (b) (c ...))";
+#print "ok 7\n";
+#
+print "not " unless $t eq "Set::Object(b)";
+print "ok 2\n";
+
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/symmdiff.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/symmdiff.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/symmdiff.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,88 @@
+use Set::Object;
+
+print "1..21\n";
+
+my $a = Set::Object->new("a".."e");
+my $b = Set::Object->new("c".."g");
+
+my $d = $a->symmetric_difference($b);
+
+print "not " unless $d eq "Set::Object(a b f g)";
+print "ok 1\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 2\n";
+
+print "not " unless $b eq "Set::Object(c d e f g)";
+print "ok 3\n";
+
+my $e = $a % $b;
+
+print "not " unless $e eq "Set::Object(a b f g)";
+print "ok 4\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 5\n";
+
+print "not " unless $b eq "Set::Object(c d e f g)";
+print "ok 6\n";
+
+my $f = $b->symmetric_difference($a);
+
+print "not " unless $f eq "Set::Object(a b f g)";
+print "ok 7\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 8\n";
+
+print "not " unless $b eq "Set::Object(c d e f g)";
+print "ok 9\n";
+
+my $g = $b % $a;
+
+print "not " unless $g eq "Set::Object(a b f g)";
+print "ok 10\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 11\n";
+
+print "not " unless $b eq "Set::Object(c d e f g)";
+print "ok 12\n";
+
+my $h = $a % "x";
+
+print "not " unless $h eq "Set::Object(a b c d e x)";
+print "ok 13\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 14\n";
+
+my $i = "y" % $a;
+
+print "not " unless $i eq "Set::Object(a b c d e y)";
+print "ok 15\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 16\n";
+
+my $j = $a % "c";
+
+print "not " unless $j eq "Set::Object(a b d e)";
+print "ok 17\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 18\n";
+
+my $k = "e" % $a;
+
+print "not " unless $k eq "Set::Object(a b c d)";
+print "ok 19\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 20\n";
+
+my $l = Set::Object->new("a", "b");
+my $m = Set::Object->new("b", "c");
+
+print "not " unless $l % $m eq "Set::Object(a c)";
+print "ok 21\n";
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/union.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/union.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/union.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,67 @@
+use Set::Object;
+
+print "1..16\n";
+
+my $a = Set::Object->new("a".."e");
+my $b = Set::Object->new("c".."g");
+
+my $d = $a->union($b);
+
+print "not " unless $d eq "Set::Object(a b c d e f g)";
+print "ok 1\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 2\n";
+
+print "not " unless $b eq "Set::Object(c d e f g)";
+print "ok 3\n";
+
+my $e = $a + $b;
+
+print "not " unless $e eq "Set::Object(a b c d e f g)";
+print "ok 4\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 5\n";
+
+print "not " unless $b eq "Set::Object(c d e f g)";
+print "ok 6\n";
+
+my $f = $b->union($a);
+
+print "not " unless $f eq "Set::Object(a b c d e f g)";
+print "ok 7\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 8\n";
+
+print "not " unless $b eq "Set::Object(c d e f g)";
+print "ok 9\n";
+
+my $g = $b + $a;
+
+print "not " unless $g eq "Set::Object(a b c d e f g)";
+print "ok 10\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 11\n";
+
+print "not " unless $b eq "Set::Object(c d e f g)";
+print "ok 12\n";
+
+my $h = $a + "x";
+
+print "not " unless $h eq "Set::Object(a b c d e x)";
+print "ok 13\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 14\n";
+
+my $i = "y" + $a;
+
+print "not " unless $i eq "Set::Object(a b c d e y)";
+print "ok 15\n";
+
+print "not " unless $a eq "Set::Object(a b c d e)";
+print "ok 16\n";
+
Added: packages/libset-object-perl/branches/upstream/current/t/scalar/unique.t
===================================================================
--- packages/libset-object-perl/branches/upstream/current/t/scalar/unique.t 2005-04-05 22:40:02 UTC (rev 883)
+++ packages/libset-object-perl/branches/upstream/current/t/scalar/unique.t 2005-04-05 22:40:15 UTC (rev 884)
@@ -0,0 +1,32 @@
+use Set::Object;
+
+print "1..4\n";
+
+my $a = Set::Object->new("a".."e");
+my $b = Set::Object->new("c".."g");
+my $c = Set::Object->new();
+
+my $d = $a->unique($b);
+
+print "not " unless $d eq "Set::Object(a b f g)";
+print "ok 1\n";
+
+my $e = $b->unique($a);
+
+print "not " unless $e eq "Set::Object(a b f g)";
+print "ok 2\n";
+
+my $f = $a->unique($c);
+
+print "not " unless $f eq $a;
+print "ok 3\n";
+
+my $g = $a->unique($a);
+
+print "not " unless $g eq "Set::Object()";
+print "ok 4 # $g\n";
+
+
+
+
+
More information about the Pkg-perl-cvs-commits
mailing list