r886 - in packages/libset-object-perl/trunk: . debian lib/Set t
Gunnar Wolf
gwolf at costa.debian.org
Sun Jul 17 08:09:10 UTC 2005
Author: gwolf
Date: 2005-04-05 22:45:56 +0000 (Tue, 05 Apr 2005)
New Revision: 886
Added:
packages/libset-object-perl/trunk/t/ingy/
packages/libset-object-perl/trunk/t/object/
packages/libset-object-perl/trunk/t/scalar/
Removed:
packages/libset-object-perl/trunk/t/Person.pm
packages/libset-object-perl/trunk/t/Saint.pm
packages/libset-object-perl/trunk/t/abuse.t
packages/libset-object-perl/trunk/t/clear.t
packages/libset-object-perl/trunk/t/difference.t
packages/libset-object-perl/trunk/t/equal.t
packages/libset-object-perl/trunk/t/flags.t
packages/libset-object-perl/trunk/t/includes.t
packages/libset-object-perl/trunk/t/insert.t
packages/libset-object-perl/trunk/t/intersection.t
packages/libset-object-perl/trunk/t/members.t
packages/libset-object-perl/trunk/t/properties.t
packages/libset-object-perl/trunk/t/refcount.t
packages/libset-object-perl/trunk/t/remove.t
packages/libset-object-perl/trunk/t/storable.t
packages/libset-object-perl/trunk/t/subsuper.t
packages/libset-object-perl/trunk/t/symmetric_difference.t
packages/libset-object-perl/trunk/t/union.t
Modified:
packages/libset-object-perl/trunk/Changes
packages/libset-object-perl/trunk/MANIFEST
packages/libset-object-perl/trunk/META.yml
packages/libset-object-perl/trunk/Makefile.PL
packages/libset-object-perl/trunk/Object.xs
packages/libset-object-perl/trunk/README
packages/libset-object-perl/trunk/debian/changelog
packages/libset-object-perl/trunk/lib/Set/Object.pm
Log:
Upstream release 1.10
Modified: packages/libset-object-perl/trunk/Changes
===================================================================
--- packages/libset-object-perl/trunk/Changes 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/Changes 2005-04-05 22:45:56 UTC (rev 886)
@@ -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/trunk/MANIFEST
===================================================================
--- packages/libset-object-perl/trunk/MANIFEST 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/MANIFEST 2005-04-05 22:45:56 UTC (rev 886)
@@ -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/trunk/META.yml
===================================================================
--- packages/libset-object-perl/trunk/META.yml 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/META.yml 2005-04-05 22:45:56 UTC (rev 886)
@@ -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/trunk/Makefile.PL
===================================================================
--- packages/libset-object-perl/trunk/Makefile.PL 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/Makefile.PL 2005-04-05 22:45:56 UTC (rev 886)
@@ -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/trunk/Object.xs
===================================================================
--- packages/libset-object-perl/trunk/Object.xs 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/Object.xs 2005-04-05 22:45:56 UTC (rev 886)
@@ -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,9 +326,7 @@
for (item = 1; item < items; ++item)
{
-
- if (!SvROK(ST(item))) continue;
- iset_insert_one(s, ST(item));
+ ISET_INSERT(s, ST(item));
}
IF_DEBUG(warn("set!\n"));
@@ -250,19 +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)
{
- if (!SvROK(ST(item))) continue;
- 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;
@@ -272,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;
@@ -299,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
@@ -356,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);
@@ -399,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)
{
@@ -424,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
@@ -439,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,
@@ -656,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");
@@ -665,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);
@@ -672,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/trunk/README
===================================================================
--- packages/libset-object-perl/trunk/README 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/README 2005-04-05 22:45:56 UTC (rev 886)
@@ -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/trunk/debian/changelog
===================================================================
--- packages/libset-object-perl/trunk/debian/changelog 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/debian/changelog 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,3 +1,10 @@
+libset-object-perl (1.10-1) unstable; urgency=low
+
+ * New upstream release
+ * Fixed wront debian/watch file
+
+ -- Gunnar Wolf <gwolf at debian.org> Tue, 5 Apr 2005 17:40:46 -0500
+
libset-object-perl (1.08-1) unstable; urgency=low
* New upstream release
Modified: packages/libset-object-perl/trunk/lib/Set/Object.pm
===================================================================
--- packages/libset-object-perl/trunk/lib/Set/Object.pm 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/lib/Set/Object.pm 2005-04-05 22:45:56 UTC (rev 886)
@@ -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__
Deleted: packages/libset-object-perl/trunk/t/Person.pm
===================================================================
--- packages/libset-object-perl/trunk/t/Person.pm 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/Person.pm 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,94 +0,0 @@
-
-package Person;
-
-use overload
- '""' => 'stringify',
- '==' => 'equals',
- '!=' => 'notequals',
- fallback => 1;
-
-sub new
-{
- ++$n;
- my $type = shift;
- my $self = bless { @_ }, $type;
- return $self;
-}
-
-sub DESTROY
-{
- --$n;
-}
-
-sub populate
-{
- no strict 'vars';
-
- $homer = new Person( firstname => 'Homer', name => 'Simpson' );
- $marge = new Person( firstname => 'Marge', name => 'Simpson' );
- $bart = new Person( firstname => 'Bart', name => 'Simpson' );
- $lisa = new Person( firstname => 'Lisa', name => 'Simpson' );
- $maggie = new Person( firstname => 'Maggie', name => 'Simpson' );
-
- @simpsons = ($homer, $marge, $bart, $lisa, $maggie);
-
- $burns = new Person( firstname => 'Montgomery', name => 'Burns' );
- $skinner = new Person( firstname => 'Seymour', name => 'Skinner' );
-
- $patty = new Person( firstname => 'Patty', name => 'Bouvier' );
- $selma = new Person( firstname => 'Selma', name => 'Bouvier' );
-
- $n;
-}
-
-sub exterminate
-{
- no strict 'vars';
-
- undef $homer;
- undef $marge;
- undef $bart;
- undef $lisa;
- undef $maggie;
-
- undef @simpsons;
-
- undef $burns;
- undef $skinner;
-
- undef $patty;
- undef $selma;
-
- $n;
-}
-
-sub same
-{
- my ($l1, $l2) = @_;
- my @l1 = sort { $a->{firstname} cmp $b->{firstname} } @$l1;
- my @l2 = sort { $a->{firstname} cmp $b->{firstname} } @$l2;
- foreach (@l1) { return 'not ' unless $_ eq shift @l2 }
- '';
-}
-
-sub stringify
-{
- my $self = shift;
-
- return "$self->{firstname} $self->{name}";
-}
-
-sub equals
-{
- my $a = shift;
- my $b = shift;
-
- return ( $a->{firstname} eq $b->{firstname} &&
- $a->{name} eq $b->{name} )
-}
-
-sub notequals {
- !equals(@_);
-}
-
-1;
Deleted: packages/libset-object-perl/trunk/t/Saint.pm
===================================================================
--- packages/libset-object-perl/trunk/t/Saint.pm 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/Saint.pm 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,17 +0,0 @@
-package Saint;
-
-# `empty subclass' test
-
-use vars qw(@ISA);
-
- at ISA = qw(Person);
-
-sub stringify {
-
- my $self = shift;
-
- return "Saint $self->{firstname} $self->{name}";
-
-}
-
-1;
Deleted: packages/libset-object-perl/trunk/t/abuse.t
===================================================================
--- packages/libset-object-perl/trunk/t/abuse.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/abuse.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,63 +0,0 @@
-#!/usr/bin/perl -w
-
-use strict;
-use Test::More tests => 21;
-use Set::Object;
-
-my @objects = ( bless([], "Bob"),
- bless([], "Jane"),
- bless([], "Bernie"));
-
-my $set = Set::Object->new(@objects);
-
-# This test is because I once found as_string getting called
-# completely out of context, so I added an explicit check
-eval { Set::Object::as_string("yo momma") };
-like($@, qr/Tried to use as_string/, "as_string");
-
-is(($set == "doorpost"), undef, "== operator");
-is($set->equal(["pocketknife"]), undef, "equal method");
-
-is(($set != "doorpost"), 1, "!= operator");
-is($set->not_equal(["pocketknife"]), 1, "not_equal method");
-
-ok(( $set->union([ "carborettor" ]) == $set), "union method");
-
-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");
-eval { my $x = $set->intersection([ "octarine" ]) };
-like($@, qr/Tried to .*intersection.*ARRAY/, "intersection method");
-
-eval { my $x = $set - { "deep" => "purple" } };
-like($@, qr/Tried to .*difference.*HASH/, "- operator");
-eval { my $x = $set->difference({ "uriah" => "heep" }) };
-like($@, qr/Tried to .*difference.*HASH/, "difference");
-
-eval { my $x = $set % $objects[0] };
-like($@, qr/Tried to .*symmetric.*Bob/, "% operator");
-eval { my $x = $set->symmetric_difference($objects[1]) };
-like($@, qr/Tried to .*symmetric.*Jane/, "symmetric_difference");
-
-eval { my $x = $set < $objects[0] };
-like($@, qr/Tried to .*proper subset.*Bob/, "< operator");
-eval { my $x = $set->proper_subset($objects[1]) };
-like($@, qr/Tried to .*proper subset.*Jane/, "proper_subset");
-
-eval { my $x = $set <= $objects[0] };
-like($@, qr/Tried to find subset.*Bob/, "<= operator");
-eval { my $x = $set->subset($objects[1]) };
-like($@, qr/Tried to find subset.*Jane/, "subset");
-
-eval { my $x = $set > $objects[0] };
-like($@, qr/Tried to .*proper superset.*Bob/, "> operator");
-eval { my $x = $set->proper_superset($objects[1]) };
-like($@, qr/Tried to .*proper superset.*Jane/, "proper_superset");
-
-eval { my $x = $set >= $objects[0] };
-like($@, qr/Tried to find superset.*Bob/, ">= operator");
-eval { my $x = $set->superset($objects[1]) };
-like($@, qr/Tried to find superset.*Jane/, "superset");
-
Deleted: packages/libset-object-perl/trunk/t/clear.t
===================================================================
--- packages/libset-object-perl/trunk/t/clear.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/clear.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,18 +0,0 @@
-use Set::Object;
-
-require 't/Person.pm';
-package Person;
-
-populate();
-
-$simpsons = Set::Object->new(@simpsons);
-
-print "1..2\n";
-
-$simpsons->clear();
-print 'not' unless $simpsons->size() == 0;
-print "ok 1\n";
-
-$simpsons->insert(@simpsons);
-print 'not' unless $simpsons->size() == @simpsons;
-print "ok 2\n";
Deleted: packages/libset-object-perl/trunk/t/difference.t
===================================================================
--- packages/libset-object-perl/trunk/t/difference.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/difference.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,29 +0,0 @@
-use Set::Object;
-
-require 't/Person.pm';
-package Person;
-
-populate();
-
-$simpsons = Set::Object->new($homer, $marge);
-$bouviers = Set::Object->new($marge, $patty, $selma);
-$simpsons_only = Set::Object->new($homer);
-$bouviers_only = Set::Object->new($patty, $selma);
-$empty = Set::Object->new;
-
-print "1..5\n";
-
-print 'not ' unless $simpsons->difference($bouviers) == $simpsons_only;
-print "ok 1\n";
-
-print 'not ' unless $simpsons - $bouviers == $simpsons_only;
-print "ok 2\n";
-
-print 'not ' unless $simpsons - $simpsons == $empty;
-print "ok 3\n";
-
-print 'not ' unless $simpsons_only - $bouviers_only == $simpsons_only;
-print "ok 4\n";
-
-print 'not ' unless $simpsons - $empty == $simpsons;
-print "ok 5\n";
Deleted: packages/libset-object-perl/trunk/t/equal.t
===================================================================
--- packages/libset-object-perl/trunk/t/equal.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/equal.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,24 +0,0 @@
-use Set::Object;
-
-require 't/Person.pm';
-package Person;
-
-populate();
-
-my $simpsons1 = Set::Object->new($homer, $marge);
-my $simpsons2 = Set::Object->new($homer, $marge);
-my $bouviers = Set::Object->new($marge, $patty, $selma, $patty, $selma);
-
-print "1..4\n";
-
-print 'not ' unless $simpsons1 == $simpsons1;
-print "ok 1\n";
-
-print 'not ' if $simpsons1 != $simpsons1;
-print "ok 2\n";
-
-print 'not ' unless $simpsons1 != $bouviers;
-print "ok 3\n";
-
-print 'not ' if $simpsons1 == $bouviers;
-print "ok 4\n";
Deleted: packages/libset-object-perl/trunk/t/flags.t
===================================================================
--- packages/libset-object-perl/trunk/t/flags.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/flags.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,39 +0,0 @@
-#!/usr/bin/perl -w
-#
-# check that objects retain things like overloading after going in
-# and out of Set::Object containers
-#
-
-use strict;
-
-use Set::Object;
-
-require 't/Person.pm';
-require 't/Saint.pm';
-
-print "1..2\n";
-
-my $person = new Person( firstname => "Montgomery", name => "Burns" );
-
-my $set = Set::Object->new($person);
-
-my ($newperson) = $set->members();
-
-if ($newperson ne "Montgomery Burns") {
- print "not ";
-}
-print "ok 1\n";
-
-my $saint = Saint->new( firstname => "Timothy", name => "Leary" );
-
-$set = Set::Object->new($saint);
-
-my ($newsaint) = $set->members();
-
-if ($newsaint ne "Saint Timothy Leary") {
- print "not ";
-}
-
-print "ok 2\n";
-
-
Deleted: packages/libset-object-perl/trunk/t/includes.t
===================================================================
--- packages/libset-object-perl/trunk/t/includes.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/includes.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,31 +0,0 @@
-# -*- perl -*-
-
-use Set::Object;
-
-require 't/Person.pm';
-package Person;
-use Test::More tests => 7;
-
-Set::Object->new->includes( $homer );
-
-populate();
-
-$simpsons = Set::Object->new( $homer, $marge, $bart, $lisa, $maggie );
-
-ok( $simpsons->includes(), "Set::Object->includes()" );
-
-ok( $simpsons->includes($bart), "Set::Object->includes(single)" );
-
-ok( $simpsons->includes($homer, $marge, $bart, $lisa, $maggie),
- "Set::Object->includes(many)" );
-
-ok( !$simpsons->includes($burns), "!Set::Object->includes(non-member)");
-
-ok( !$simpsons->includes($homer, $burns, $marge),
- "!Set::Object->includes(members, non-member)");
-
-ok( !$simpsons->includes(Set::Object->new()),
- "!Set::Object->includes(Set::Object->new())");
-
-ok( !$simpsons->includes("bogon"),
- "!Set::Object->includes('bogon')");
Copied: packages/libset-object-perl/trunk/t/ingy (from rev 885, packages/libset-object-perl/branches/upstream/current/t/ingy)
Deleted: packages/libset-object-perl/trunk/t/insert.t
===================================================================
--- packages/libset-object-perl/trunk/t/insert.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/insert.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,62 +0,0 @@
-# -*- perl -*-
-
-use Set::Object;
-
-require 't/Person.pm';
-package Person;
-use Test::More tests => 18;
-
-populate();
-
-$simpsons = Set::Object->new;
-
-is($simpsons->size(), 0, "Set::Object->size() [ no contents ]");
-
-$added = $simpsons->insert($homer);
-is($added, 1, "Set::Object->insert() [ returned # added ]");
-is($simpsons->size(), 1, "Set::Object->size() [ one member ]");
-
-$added = $simpsons->insert($homer);
-is($added, 0, "Set::Object->insert() [ returned # added ]");
-is($simpsons->size(), 1, "Set::Object->size() [ one member ]");
-
-$added = $simpsons->insert($marge);
-is($added, 1, "Set::Object->insert() [ returned # added ]");
-is($simpsons->size(), 2, "Set::Object->size() [ two members ]");
-
-$simpsons->insert($maggie, $homer, $bart, $marge, $bart, $lisa, $lisa, $maggie);
-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");
-
-my $test = new Set::Object;
-eval { $test->insert("bogon"); };
-is ( $test."", "Set::Object()", "as_string on bogon-ified set");
-
-# array refs
-my $array;
-$test->insert($array = [ "array", "ref" ]);
-my $array2 = [ "array", "ref" ];
-
-$test->insert($array);
-is ($test->size(), 1, "Inserted an array OK");
-ok ($test->includes($array), "Can put non-objects in a set");
-ok (!$test->includes($array2), "Lookup of identical item doesn't work");
-
-like ( $test."", qr/Set::Object\(ARRAY/, "Inserted an array OK");
-
-# hash refs
-$test->clear();
-my $hash;
-$test->insert($hash = { "hash" => "ref" });
-my $hash2 = { "hash" => "ref" };
-
-$test->insert($hash);
-is ($test->size(), 1, "Inserted an hash OK");
-ok ($test->includes($hash), "Can put non-objects in a set");
-ok (!$test->includes($hash2), "Lookup of identical item doesn't work");
-
-like ( $test."", qr/Set::Object\(HASH/, "Inserted an array OK");
-
Deleted: packages/libset-object-perl/trunk/t/intersection.t
===================================================================
--- packages/libset-object-perl/trunk/t/intersection.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/intersection.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,33 +0,0 @@
-use Set::Object;
-
-require 't/Person.pm';
-package Person;
-
-populate();
-
-$bart = $bart;
-$marge = $marge;
-
-$kids = Set::Object->new($bart, $lisa, $maggie);
-$females = Set::Object->new($marge, $lisa, $maggie);
-$babies = Set::Object->new($maggie);
-
-print "1..6\n";
-
-print 'not ' unless $kids->intersection($females) == Set::Object->new($lisa, $maggie);
-print "ok 1\n";
-
-print 'not ' unless $kids->intersection($females, $babies) == Set::Object->new($maggie);
-print "ok 2\n";
-
-print 'not ' unless $kids * $females == Set::Object->new($lisa, $maggie);
-print "ok 3\n";
-
-print 'not ' unless $kids * $females == $females * $kids;
-print "ok 4\n";
-
-print 'not ' unless $kids * $kids == $kids;
-print "ok 5\n";
-
-print 'not ' unless ($kids * Set::Object->new())->size == 0;
-print "ok 6\n";
Deleted: packages/libset-object-perl/trunk/t/members.t
===================================================================
--- packages/libset-object-perl/trunk/t/members.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/members.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,32 +0,0 @@
-use Set::Object;
-
-require 't/Person.pm';
-package Person;
-
-populate();
-
-$simpsons = Set::Object->new();
-
-print "1..3\n";
-
-print 'not ' if $simpsons->members();
-print "ok 1\n";
-
- at members1 = @simpsons;
- at members1 = sort { $a->{firstname} cmp $b->{firstname} } @members1;
-
-$simpsons->insert(@members1);
- at members2 = $simpsons->members();
-
-print 'not ' unless @members2 == 5;
-print "ok 2\n";
-
- at members2 = sort @members2;
-
-foreach $member1 (@members1)
-{
- my $foo = shift(@members2);
- unless ($member1 == $foo) { print 'not '; last }
-}
-
-print "ok 3\n";
Copied: packages/libset-object-perl/trunk/t/object (from rev 885, packages/libset-object-perl/branches/upstream/current/t/object)
Deleted: packages/libset-object-perl/trunk/t/properties.t
===================================================================
--- packages/libset-object-perl/trunk/t/properties.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/properties.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,329 +0,0 @@
-#!/usr/bin/perl -w
-
-use strict;
-use Test::More tests => 79;
-use Set::Object qw(ish_int is_int is_double is_string is_object
- blessed reftype refaddr is_key);
-
-is(is_int(0), 1, "is_int(0)");
-is(is_int(7), 1, "is_int(7)");
-is(is_key(7), 1, "is_key(7)");
-is(is_int(7.0), undef, "!is_int(7.0)");
-is(is_key(7.0), 1, "is_key(7.0)");
-is(is_int('7'), undef, "!is_int('7')");
-is(is_key('7'), 1, "is_key('7')");
-
-is(is_string(7), undef, "!is_string()");
-is(is_string(7.0), undef, "!is_string(7.0)");
-is(is_string("7"), 1, "is_string('7')");
-
-is(is_double(7), undef, "!is_double(7)");
-is(is_double(7.0), 1, "is_double(7.0)");
-is(is_double("7"), undef, "!is_double('7')");
-
-# behvaiour for numeric strings
-my $foo;
-is(is_int($foo="7"), undef, "!is_int(\$foo = '7')");
-is(is_double($foo), undef, "!is_double($foo)");
-is(ish_int($foo), undef, "!ish_int($foo)");
-
-# behaviour changes between Perls
-#is(is_int($foo+0), 1, "is_int(\$foo + 0)");
-is(is_int(int($foo)), 1, "is_int(int(\$foo))");
-# behaviour changes between Perls
-#is(is_double($foo), undef, "is_double($foo)");
-is(ish_int($foo), 7, "ish_int($foo)");
-
-is(is_double($foo+0.01-0.01), 1, "is_double(\$foo + 0)");
-is(is_double($foo), 1, "is_double($foo)");
-is(is_int(int($foo)), 1, "is_int(int(\$foo))");
-is(ish_int($foo), 7, "ish_int($foo)");
-
-{
-# no warnings for brevity
-local($^W) = 0;
-
-is(ish_int($foo = "7am"), undef,
- "!defined(ish_int($foo = '7am'))");
-is(ish_int($foo + 0), 7, "ish_int(\$foo + 0) == 7");
-# behaviour changes between Perls
-#is(is_int($foo), undef, "!is_int($foo)");
-is(is_double($foo), 1, "is_double($foo)");
-#diag("foo is $foo");
-is(ish_int($foo), undef, "!defined(ish_int($foo))");
-
-is(ish_int($foo = "7.0"), undef,
- "!defined(ish_int($foo = '7.0'))");
-is(ish_int($foo + 0), 7, "ish_int($foo + 0) == 7");
-# behaviour changes between Perls
-# is(is_int($foo), undef, "!is_int($foo)");
-is(is_double($foo), 1, "is_double($foo)");
-is(ish_int($foo), undef, "!defined(ish_int($foo))");
-
-is(ish_int($foo = "7e6"), undef,
- "!defined(ish_int($foo = '7e6'))");
-is(ish_int($foo + 0), 7e6, "ish_int($foo + 0) == 7e6");
-# behaviour changes between Perls
-# is(is_int($foo), undef, "!is_int($foo)");
-is(is_double($foo), 1, "is_double($foo)");
-is(ish_int($foo), undef, "!defined(ish_int($foo))");
-
-is(ish_int($foo = "7"), undef,
- "!defined(ish_int($foo = '7'))");
-is(ish_int($foo + 0.001 - 0.001), 7, "ish_int($foo + 0) == 7");
-is(is_double($foo), 1, "is_double($foo)");
-# behaviour changes between Perls
-# is(is_int($foo), undef, "is_int($foo)");
-is(ish_int($foo), 7, "ish_int($foo) == 7");
-
-is(ish_int($foo = "0"), undef,
- "!defined(ish_int($foo = '0'))");
-is(ish_int($foo + 0.001 - 0.001), 0, "ish_int($foo + 0) == 0");
-is(is_double($foo), 1, "is_double($foo)");
-# behaviour changes between Perls
-# is(is_int($foo), undef, "is_int($foo)");
-is(ish_int($foo), 0, "ish_int($foo) == 7");
-
-# value must be within 1e-9 of an int
-is(ish_int(7.000000001234), undef,
- "!ish_int(7.000000001234)");
-is(ish_int(7.0000000001234), 7,
- "ish_int(7.0000000001234) == 7");
-
-}
-
-is(blessed($foo = []), undef, "!blessed(\$foo = [])");
-is(is_key($foo), undef, "is_key([])");
-is(reftype($foo), "ARRAY",
- "reftype(\$foo) eq 'ARRAY'");
-
-bless $foo, "This";
-is(blessed($foo), "This", "blessed(\$foo) eq 'This'");
-is(reftype($foo), "ARRAY", "reftype(\$foo) eq 'ARRAY'");
-is(is_key($foo), undef, "is_key(blessed array)");
-
-$foo = {};
-bless $foo, "This";
-is(reftype({}), "HASH", "reftype({})");
-is(reftype($foo), "HASH", "reftype(\$foo)");
-is(is_key($foo), undef, "is_key(blessed hash)");
-
-my %foo;
-my $tiehandle = tie %foo, "This";
-
-is(reftype(\%foo), "HASH", "reftype(\%foo) - tied");
-is(reftype($tiehandle),
- "ARRAY", "reftype(\$tiehandle)");
-untie(%foo);
-
-my $psuedonum = psuedonum->new(7);
-
-ok($psuedonum == 7, "Pseudonum numifies OK");
-ok($psuedonum == 7.0, "Pseudonum numifies OK");
-ok($psuedonum eq "7", "Pseudonum stringifies OK");
-is(blessed($psuedonum), "psuedonum", "Pseudonum is blessed");
-is(ish_int($psuedonum), 7, "ish_int(Pseudonum)");
-is(is_key($psuedonum), 1, "is_key(psuedonum)");
-$psuedonum = [ ];
-is(is_key($psuedonum), undef, "is_key(psuedonum/hash)");
-
-my $nevernum = nevernum->new(7);
-
-eval { if ($nevernum == 7) { } };
-ok($@, "nevernum dies when numified");
-eval { if ($nevernum == 7.0) { } };
-ok($@, "nevernum dies when doublified");
-ok($nevernum eq "7", "nevernum stringifies OK");
-ok(blessed($nevernum) eq "nevernum", "nevernum is blessed");
-is(ish_int($nevernum), undef, "ish_int(Nevernum)");
-is(is_key($nevernum), 1, "is_key(nevernum)");
-
-my $notreallynum = notreallynum->new(7);
-
-ok($notreallynum == 7, "notreallynum numifies OK");
-ok($notreallynum == 7.0, "notreallynum numifies OK");
-ok($notreallynum eq "7", "notreallynum stringifies OK");
-ok(blessed($notreallynum) eq "notreallynum", "nevernum is blessed");
-is(ish_int($notreallynum), undef, "ish_int(notreallynum)");
-is(is_key($nevernum), 1, "is_key(notreallynum)");
-
-# now test tied scalars
-$tiehandle = tie $foo, "This";
-$foo = 7;
-
-ok(tied $foo, "\$foo is tied");
-
-# my @spells = detect_magic($foo);
-# ok(@spells && $spells[0] =~ m/Magic type q/,
-# "Foo is definitely tied");
-
-#use Devel::Peek qw(Dump);
-#print Dump $foo;
-
-is(ish_int($foo), 7, "ish_int(tied var)");
-eval { _ish_int($foo) };
-like($@, qr/tie/, "ish_int(tied var)");
-is(is_key($foo), 1, "is_key(tied var)");
-
-ok(refaddr($notreallynum) > 0 && refaddr($notreallynum) != refaddr($nevernum),
- "refaddr()");
-
-exit(0);
-
-# unused debugging function
-sub showit {
- my $var = shift;
- if (defined $var) {
- if (is_int($var)) {
- return $var;
- } elsif (is_double($var)) {
- return sprintf("%e",$var);
- } elsif (is_string($var)) {
- return "`$var'";
- } elsif (my $b = blessed($var)) {
- return "Object($b)(".reftype($var).")";
- } else {
- return "onion";
- }
- } else {
- return "undef";
- }
-}
-package This;
-
-# this class is an array pretending to be a hash
-
-sub TIESCALAR {
- my $invocant = shift;
- my $test = [ ];
- return bless $test, $invocant;
-}
-
-sub TIEHASH {
- my $invocant = shift;
- my $test = [ { } ];
- return bless $test, $invocant;
-}
-
-sub FETCH {
- my $self = shift;
-
- if (@_) {
- my $key = shift;
- if (my $idx = ish_int($key)) {
- return $self->[$idx+1];
- } else {
- if (exists $self->[0]->{$key}) {
- return $self->[$self->[0]->{$key}];
- } else {
- return undef;
- }
- }
- } else {
- # scalar fetch
- return $self->[0];
- }
-}
-
-sub STORE {
- my $self = shift;
- if (@_ == 2) {
- # hash set
- my $key = shift;
-
- if (!defined $key) {
- $key = "";
- }
- } elsif (@_ == 1) {
- # scalar set
- $self->[0] = shift;
- }
-}
-
-sub UNTIE {
- my $self = shift;
- @$self=();
-}
-
-package psuedonum;
-
-use overload
- '""' => \&stringify,
- '0+' => \&numify,
- fallback => 1;
-
-sub new {
- my $self = shift;
- my $val = shift;
- return bless { val => $val }
-}
-
-sub set {
- my $self = shift;
- my $val = shift;
- $self->{val} = $val;
-}
-
-sub stringify {
- my $self = shift;
- return "$self->{val}";
-}
-
-sub numify {
- my $self = shift;
- return $self->{val} + 0;
-}
-
-package notreallynum;
-
-use overload
- '""' => \&stringify,
- fallback => 1;
-
-sub new {
- my $self = shift;
- my $val = shift;
- return bless { val => $val }
-}
-
-sub set {
- my $self = shift;
- my $val = shift;
- $self->{val} = $val;
-}
-
-sub stringify {
- my $self = shift;
- return "$self->{val}";
-}
-
-package nevernum;
-
-use overload
- '""' => \&stringify,
- 'eq' => \&equal,
- fallback => 0;
-
-sub new {
- my $self = shift;
- my $val = shift;
- return bless { val => $val }
-}
-
-sub set {
- my $self = shift;
- my $val = shift;
- $self->{val} = $val;
-}
-
-sub stringify {
- my $self = shift;
- return "$self->{val}";
-}
-
-sub equal {
- my $self = shift;
- my $other = shift;
- return $self->{val} eq $other;
-}
-
Deleted: packages/libset-object-perl/trunk/t/refcount.t
===================================================================
--- packages/libset-object-perl/trunk/t/refcount.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/refcount.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,49 +0,0 @@
-use Set::Object;
-
-require 't/Person.pm';
-package Person;
-
-print "1..9\n";
-
-$simpsons = Set::Object->new(
- new Person( firstname => 'Bart', name => 'Simpson' ),
- new Person( firstname => 'Lisa', name => 'Simpson' ),
- new Person( firstname => 'Maggie', name => 'Simpson' ) );
-
-print 'not' unless $Person::n == 3;
-print "ok 1\n";
-
-$simpsons->insert();
-print 'not ' unless $Person::n == 3;
-print "ok 2\n";
-
-$simpsons->insert($homer = new Person( firstname => 'Homer', name => 'Simpson' ));
-print 'not ' unless $Person::n == 4;
-print "ok 3\n";
-
-$simpsons->remove($homer);
-print 'not ' unless $Person::n == 4;
-print "ok 4\n";
-
-undef $homer;
-print 'not ' unless $Person::n == 3;
-print "ok 5\n";
-
-$simpsons = undef;
-print 'not ' if $Person::n;
-print "ok 6\n";
-
-my $n = 31;
-my $big = Set::Object->new( map { Person->new } 1..$n );
-print 'not ' if $Person::n != $n;
-print "ok 7\n";
-
-{
- my $same = $big - Set::Object->new();
- print 'not ' if $same->size != $n;
- print "ok 8\n";
-}
-
-$big->clear();
-print 'not ' if $Person::n;
-print "ok 9\n";
Deleted: packages/libset-object-perl/trunk/t/remove.t
===================================================================
--- packages/libset-object-perl/trunk/t/remove.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/remove.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,29 +0,0 @@
-use Set::Object;
-
-require 't/Person.pm';
-package Person;
-
-populate();
-
-$patty = $patty;
-$selma = $selma;
-$burns = $burns;
-
-Set::Object->new->remove($patty);
-
-$simpsons = Set::Object->new($homer, $marge, $bart, $lisa, $maggie);
-
-print "1..3\n";
-
-$removed = $simpsons->remove($homer);
-print 'not ' unless $simpsons->size() == 4 && $removed == 1
- && $simpsons == Set::Object->new($marge, $bart, $lisa, $maggie);
-print "ok 1\n";
-
-$removed = $simpsons->remove($burns);
-print 'not ' unless $simpsons->size() == 4 && $removed == 0;
-print "ok 2\n";
-
-$removed = $simpsons->remove($patty, $marge, $selma);
-print 'not ' unless $simpsons->size() == 3 && $removed == 1;
-print "ok 3\n";
Copied: packages/libset-object-perl/trunk/t/scalar (from rev 885, packages/libset-object-perl/branches/upstream/current/t/scalar)
Deleted: packages/libset-object-perl/trunk/t/storable.t
===================================================================
--- packages/libset-object-perl/trunk/t/storable.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/storable.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,48 +0,0 @@
-# -*- perl -*-
-#
-# Storable test for Set::Object objects
-
-use strict;
-
-BEGIN {
- eval "use Storable qw(freeze thaw dclone)";
- if ($@) {
- eval 'use Test::More skip_all => "Storable not installed"';
- exit(0);
- } else {
- eval 'use Test::More tests => 7';
- }
-}
-
-use_ok("Set::Object", qw(refaddr));
-my $objects = [ map { bless { $_ => rand(42) }, $_ }
- qw(Barnie Fred Wilma) ];
-
-my $stored = freeze ($objects);
-is_deeply(thaw($stored), $objects, "Storable works");
-
-my $set = Set::Object->new(@$objects);
-$stored = freeze($set);
-
-use Data::Dumper;
-#print Dumper $stored;
-
-my $returned = thaw($stored);
-#print "no segfault yet!\n";
-#diag(Dumper($returned, $set));
-is_deeply([ sort { ref($a) cmp ref($b) } $returned->members ],
- [ sort { ref($a) cmp ref($b) } $set->members ],
- "Set::Object serialises via Storable!");
-isnt($$returned, $$set, "thaw returned a new Set::Object");
-
-my $spawned = dclone($set);
-is_deeply([ sort { ref($a) cmp ref($b) } $spawned->members ],
- [ sort { ref($a) cmp ref($b) } $set->members ],
- "Set::Object dclones via Storable!");
-isnt($$spawned, $$set, "dclone returned a new Set::Object");
-
-my $old;
-my $test = dclone ($old = [ map { Set::Object->new() } (1..1000) ]);
-
-is(@$old, @$test, "empty sets");
-
Deleted: packages/libset-object-perl/trunk/t/subsuper.t
===================================================================
--- packages/libset-object-perl/trunk/t/subsuper.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/subsuper.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,56 +0,0 @@
-use Set::Object;
-
-require 't/Person.pm';
-package Person;
-
-populate();
-
-use vars qw( $homer $marge $bart $lisa $maggie );
-
-$simpsons = Set::Object->new( $homer, $marge, $bart, $lisa, $maggie );
-$parents = Set::Object->new( $homer, $marge );
-$empty = Set::Object->new();
-
-print "1..14\n";
-
-print 'not ' unless $parents < $simpsons;
-print "ok 1\n";
-
-print 'not ' if $simpsons < $parents;
-print "ok 2\n";
-
-print 'not ' if $parents < $parents;
-print "ok 3\n";
-
-print 'not ' unless $parents <= $simpsons;
-print "ok 4\n";
-
-print 'not ' unless $parents <= $parents;
-print "ok 5\n";
-
-print 'not ' unless $empty < $simpsons;
-print "ok 6\n";
-
-print 'not ' unless $empty <= $simpsons;
-print "ok 7\n";
-
-print 'not ' unless $simpsons > $parents;
-print "ok 8\n";
-
-print 'not ' if $parents > $simpsons;
-print "ok 9\n";
-
-print 'not ' if $simpsons > $simpsons;
-print "ok 10\n";
-
-print 'not ' unless $simpsons >= $parents;
-print "ok 11\n";
-
-print 'not ' unless $simpsons >= $simpsons;
-print "ok 12\n";
-
-print 'not ' unless $parents > $empty;
-print "ok 13\n";
-
-print 'not ' unless $parents >= $empty;
-print "ok 14\n";
Deleted: packages/libset-object-perl/trunk/t/symmetric_difference.t
===================================================================
--- packages/libset-object-perl/trunk/t/symmetric_difference.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/symmetric_difference.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,29 +0,0 @@
-use Set::Object;
-
-require 't/Person.pm';
-package Person;
-
-populate();
-
-$homer = $homer;
-$patty = $patty;
-$selma = $selma;
-
-$simpsons = Set::Object->new($homer, $marge);
-$bouviers = Set::Object->new($marge, $patty, $selma);
-$trouble = Set::Object->new($homer, $patty, $selma);
-$empty = Set::Object->new;
-
-print "1..4\n";
-
-print 'not ' unless $simpsons->symmetric_difference($bouviers) == $trouble;
-print "ok 1\n";
-
-print 'not ' unless $simpsons % $bouviers == $trouble;
-print "ok 2\n";
-
-print 'not ' unless $simpsons % $simpsons == $empty;
-print "ok 3\n";
-
-print 'not ' unless $simpsons % $empty == $simpsons;
-print "ok 4\n";
Deleted: packages/libset-object-perl/trunk/t/union.t
===================================================================
--- packages/libset-object-perl/trunk/t/union.t 2005-04-05 22:40:26 UTC (rev 885)
+++ packages/libset-object-perl/trunk/t/union.t 2005-04-05 22:45:56 UTC (rev 886)
@@ -1,28 +0,0 @@
-use Set::Object;
-
-require 't/Person.pm';
-package Person;
-
-populate();
-
-$simpsons = Set::Object->new($homer, $marge);
-$bouviers = Set::Object->new($marge, $patty, $selma);
-$both = Set::Object->new($homer, $marge, $patty, $selma);
-$empty = Set::Object->new;
-
-print "1..5\n";
-
-print 'not ' unless $simpsons->union($bouviers) == $both;
-print "ok 1\n";
-
-print 'not ' unless $simpsons + $bouviers == $both;
-print "ok 2\n";
-
-print 'not ' unless $bouviers + $simpsons == $both;
-print "ok 3\n";
-
-print 'not ' unless $simpsons + $simpsons == $simpsons;
-print "ok 4\n";
-
-print 'not ' unless $simpsons + $empty == $simpsons;
-print "ok 5\n";
More information about the Pkg-perl-cvs-commits
mailing list