File Coverage

blib/lib/Set/Object.pm
Criterion Covered Total %
statement 247 303 81.5
branch 90 114 78.9
condition 22 45 48.8
subroutine 57 71 80.2
pod 32 38 84.2
total 448 571 78.4


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Set::Object - set of objects and strings
4              
5             =head1 SYNOPSIS
6              
7             use Set::Object qw(set);
8              
9             my $set = set(); # or Set::Object->new()
10              
11             $set->insert(@thingies);
12             $set->remove(@thingies);
13              
14             @items = @$set; # or $set->members for the unsorted array
15              
16             $union = $set1 + $set2;
17             $intersection = $set1 * $set2;
18             $difference = $set1 - $set2;
19             $symmetric_difference = $set1 % $set2;
20              
21             print "set1 is a proper subset of set2"
22             if $set1 < $set2;
23              
24             print "set1 is a subset of set2"
25             if $set1 <= $set2;
26              
27             # common idiom - iterate over any pure Perl structure
28             use Set::Object qw(reftype);
29             my @stack = $root;
30             my $seen = Set::Object->new(@stack);
31             while (my $object = pop @stack) {
32             if (reftype $object eq "HASH") {
33             # do something with hash members
34              
35             # add the new nodes to the stack
36             push @stack, grep { ref $_ && $seen->insert($_) }
37             values %$object;
38             }
39             elsif (reftype $object eq "ARRAY") {
40             # do something with array members
41              
42             # add the new nodes to the stack
43             push @stack, grep { ref $_ && $seen->insert($_) }
44             @$object;
45              
46             }
47             elsif (reftype $object =~ /SCALAR|REF/) {
48             push @stack, $$object
49             if ref $$object && $seen->insert($$object);
50             }
51             }
52              
53             =head1 DESCRIPTION
54              
55             This modules implements a set of objects, that is, an unordered
56             collection of objects without duplication.
57              
58             The term I is applied loosely - for the sake of
59             L, anything that is a reference is considered an object.
60              
61             L 1.09 and later includes support for inserting scalars
62             (including the empty string, but excluding C) as well as
63             objects. This can be thought of as (and is currently implemented as)
64             a degenerate hash that only has keys and no values. Unlike objects
65             placed into a Set::Object, scalars that are inserted will be flattened
66             into strings, so will lose any magic (eg, tie) or other special bits
67             that they went in with; only strings come out.
68              
69             =head1 CONSTRUCTORS
70              
71             =head2 Set::Object->new( [I] )
72              
73             Return a new C containing the elements passed in I.
74              
75             =head2 C
76              
77             Return a new C filled with C<@members>. You have to
78             explicitly import this method.
79              
80             B: this function is now called as a method
81             to return new sets the various methods that return a new set, such as
82             C<-Eintersection>, C<-Eunion>, etc and their overloaded
83             counterparts. The default method always returns C
84             objects, preserving previous behaviour and not second guessing the
85             nature of your derived L class.
86              
87             =head2 C
88              
89             Return a new C, filled with C<@members>. You have
90             to explicitly import this method.
91              
92             =head1 INSTANCE METHODS
93              
94             =head2 insert( [I] )
95              
96             Add items to the C.
97              
98             Adding the same object several times is not an error, but any
99             C will contain at most one occurrence of the same object.
100              
101             Returns the number of elements that were actually added. As of
102             Set::Object 1.23, C will not insert.
103              
104             =head2 includes( [I] )
105              
106             =head2 has( [I] )
107              
108             =head2 contains( [I] )
109              
110             Return C if B the objects in I are members of the
111             C. I may be empty, in which case C is
112             always returned.
113              
114             As of Set::Object 1.23, C will never appear to be present in
115             any set (even if the set contains the empty string). Prior to 1.23,
116             there would have been a run-time warning.
117              
118             =head2 member( [I] )
119              
120             =head2 element( [I] )
121              
122             Like C, but takes a single item to check and returns that
123             item if the value is found, rather than just a true value.
124              
125             =head2 members
126              
127             =head2 elements
128              
129             Return the objects contained in the C in random (hash)
130             order.
131              
132             Note that the elements of a C in list context are returned
133             sorted - C<@$set> - so using the C method is much faster.
134              
135             =head2 size
136              
137             Return the number of elements in the C.
138              
139             =head2 remove( [I] )
140              
141             =head2 delete( [I] )
142              
143             Remove objects from a C.
144              
145             Removing the same object more than once, or removing an object absent
146             from the C is not an error.
147              
148             Returns the number of elements that were actually removed.
149              
150             As of Set::Object 1.23, removing C is safe (but having an
151             C in the passed in list does not increase the return value,
152             because it could never be in the set)
153              
154             =head2 weaken
155              
156             Makes all the references in the set "weak" - that is, they do not
157             increase the reference count of the object they point to, just like
158             L's C function.
159              
160             This was introduced with Set::Object 1.16, and uses a brand new type
161             of magic. B. If you get segfaults when you use
162             C, please reduce your problem to a test script before
163             submission.
164              
165             B as of Set::Object 1.19, you may use the C function
166             to make weak sets, or Cnew>, or import the
167             C constructor from C instead. See
168             L for more.
169              
170             B:> this method re-blesses
171             the invocant to C. Override the method C
172             in your sub-class to control this behaviour.
173              
174             =head2 is_weak
175              
176             Returns a true value if this set is a weak set.
177              
178             =head2 strengthen
179              
180             Turns a weak set back into a normal one.
181              
182             B:> this method re-blesses
183             the invocant to C. Override the method C in
184             your sub-class to control this behaviour.
185              
186             =head2 invert( [I] )
187              
188             For each item in I, it either removes it or adds it to the set,
189             so that a change is always made.
190              
191             Also available as the overloaded operator C, in which case it
192             expects another set (or a single scalar element), and returns a new
193             set that is the original set with all the second set's items inverted.
194              
195             =head2 clear
196              
197             Empty this C.
198              
199             =head2 as_string
200              
201             Return a textual Smalltalk-ish representation of the C.
202             Also available as overloaded operator "".
203              
204             =head2 equal( I )
205              
206             Returns a true value if I contains exactly the same members as
207             the invocant.
208              
209             Also available as overloaded operator C<==> (or C).
210              
211             =head2 not_equal( I )
212              
213             Returns a false value if I contains exactly the same members as
214             the invocant.
215              
216             Also available as overloaded operator C (or C).
217              
218             =head2 intersection( [I] )
219              
220             Return a new C containing the intersection of the
221             Cs passed as arguments.
222              
223             Also available as overloaded operator C<*>.
224              
225             =head2 union( [I] )
226              
227             Return a new C containing the union of the
228             Cs passed as arguments.
229              
230             Also available as overloaded operator C<+>.
231              
232             =head2 difference ( I )
233              
234             Return a new C containing the members of the first
235             (invocant) set with the passed Cs' elements removed.
236              
237             Also available as overloaded operator C<->.
238              
239             =head2 unique ( I )
240              
241             =head2 symmetric_difference ( I )
242              
243             Return a new C containing the members of all passed sets
244             (including the invocant), with common elements removed. This will be
245             the opposite (complement) of the I of the two sets.
246              
247             Also available as overloaded operator C<%>.
248              
249             =head2 subset( I )
250              
251             Return C if this C is a subset of I.
252              
253             Also available as operator C=>.
254              
255             =head2 proper_subset( I )
256              
257             Return C if this C is a proper subset of I
258             Also available as operator C>.
259              
260             =head2 superset( I )
261              
262             Return C if this C is a superset of I.
263             Also available as operator C=>.
264              
265             =head2 proper_superset( I )
266              
267             Return C if this C is a proper superset of I
268             Also available as operator C>.
269              
270             =head2 is_null( I )
271              
272             Returns a true value if this set does not contain any members, that
273             is, if its size is zero.
274              
275             =head1 Set::Scalar compatibility methods
276              
277             By and large, L is not and probably never will be
278             feature-compatible with L; however the following
279             functions are provided anyway.
280              
281             =head2 compare( I )
282              
283             returns one of:
284              
285             "proper intersect"
286             "proper subset"
287             "proper superset"
288             "equal"
289             "disjoint"
290              
291             =head2 is_disjoint( I )
292              
293             Returns a true value if the two sets have no common items.
294              
295             =head2 as_string_callback( I )
296              
297             Allows you to define a custom stringify function. This is only a
298             class method. If you want anything fancier than this, you should
299             sub-class Set::Object.
300              
301              
302             =head1 FUNCTIONS
303              
304             The following functions are defined by the Set::Object XS code for
305             convenience; they are largely identical to the versions in the
306             Scalar::Util module, but there are a couple that provide functions not
307             catered to by that module.
308              
309             Please use the versions in L in preference to these
310             functions. In fact, if you use these functions in your production
311             code then you may have to rewrite it some day. They are retained only
312             because they are "mostly harmless".
313              
314             =over
315              
316             =item B
317              
318             B
319              
320             Returns a true value if the passed reference (RV) is blessed. See
321             also L.
322              
323             =item B
324              
325             B
326              
327             A bit like the perl built-in C function, but returns the I
328             of reference; ie, if the reference is blessed then it returns what
329             C would have if it were not blessed. Useful for "seeing through"
330             blessed references.
331              
332             =item B
333              
334             B
335              
336             Returns the memory address of a scalar. B: this is I
337             guaranteed to be unique for scalars created in a program; memory might
338             get re-used!
339              
340             =item B, B, B
341              
342             B
343              
344             A quick way of checking the three bits on scalars - IOK (is_int), NOK
345             (is_double) and POK (is_string). Note that the exact behaviour of
346             when these bits get set is not defined by the perl API.
347              
348             This function returns the "p" versions of the macro (SvIOKp, etc); use
349             with caution.
350              
351             =item B
352              
353             B
354              
355             A quick way to check if an object has overload magic on it.
356              
357             =item B
358              
359             B
360              
361             This function returns true, if the value it is passed looks like it
362             I a representation of an I. This is so that you
363             can decide whether the value passed is a hash key or an array
364             index.
365              
366             =item B
367              
368             B
369              
370             This function returns true, if the value it is passed looks more like
371             an I to a collection than a I of a collection. Similar
372             to the looks_like_number internal function, but weird. Avoid.
373              
374             =item B
375              
376             B
377              
378             Pass to a scalar, and get the magick wand (C) used by the weak
379             set implementation. The return will be a list of integers which are
380             pointers to the actual C structure. Whatever you do don't
381             change the array :). This is used only by the test suite, and if you
382             find it useful for something then you should probably conjure up a
383             test suite and send it to me, otherwise it could get pulled.
384              
385             =back
386              
387             =head1 CLASS METHODS
388              
389             These class methods are probably only interesting to those
390             sub-classing C.
391              
392             =over
393              
394             =item strong_pkg
395              
396             When a set that was already weak is strengthened using
397             C<-Estrengthen>, it gets re-blessed into this package.
398              
399             =item weak_pkg
400              
401             When a set that was NOT already weak is weakened using
402             C<-Eweaken>, it gets re-blessed into this package.
403              
404             =item tie_array_pkg
405              
406             When the object is accessed as an array, tie the array into this
407             package.
408              
409             =item tie_hash_pkg
410              
411             When the object is accessed as a hash, tie the hash into this package.
412              
413             =back
414              
415             =head1 SERIALIZATION
416              
417             It is possible to serialize C objects via L and
418             duplicate via C; such support was added in release 1.04. As
419             of C version 1.15, it is possible to freeze scalar items,
420             too.
421              
422             However, the support for freezing scalar items introduced a backwards
423             incompatibility. Earlier versions than 1.15 will C sets frozen
424             using Set::Object 1.15 and later as a set with one item - an array
425             that contains the actual members.
426              
427             Additionally, version 1.15 had a bug that meant that it would not
428             detect C protocol upgrades, instead reverting to pre-1.15
429             behaviour.
430              
431             C 1.16 and above are capable of dealing correctly with
432             all serialized forms, as well as correctly aborting if a "newer"
433             C protocol is detected during C.
434              
435             =head1 PERFORMANCE
436              
437             The following benchmark compares C with using a hash to
438             emulate a set-like collection (this is an old benchmark, but still
439             holds true):
440              
441             use Set::Object;
442              
443             package Obj;
444             sub new { bless { } }
445              
446             @els = map { Obj->new() } 1..1000;
447              
448             require Benchmark;
449              
450             Benchmark::timethese(100, {
451             'Control' => sub { },
452             'H insert' => sub { my %h = (); @h{@els} = @els; },
453             'S insert' => sub { my $s = Set::Object->new(); $s->insert(@els) },
454             } );
455              
456             %gh = ();
457             @gh{@els} = @els;
458              
459             $gs = Set::Object->new(@els);
460             $el = $els[33];
461              
462             Benchmark::timethese(100_000, {
463             'H lookup' => sub { exists $gh{33} },
464             'S lookup' => sub { $gs->includes($el) }
465             } );
466              
467             On my computer the results are:
468              
469             Benchmark: timing 100 iterations of Control, H insert, S insert...
470             Control: 0 secs ( 0.01 usr 0.00 sys = 0.01 cpu)
471             (warning: too few iterations for a reliable count)
472             H insert: 68 secs (67.81 usr 0.00 sys = 67.81 cpu)
473             S insert: 9 secs ( 8.81 usr 0.00 sys = 8.81 cpu)
474             Benchmark: timing 100000 iterations of H lookup, S lookup...
475             H lookup: 7 secs ( 7.14 usr 0.00 sys = 7.14 cpu)
476             S lookup: 6 secs ( 5.94 usr 0.00 sys = 5.94 cpu)
477              
478             This benchmark compares the unsorted members method, against the sorted @$ list context.
479              
480             perl -MBenchmark -mList::Util -mSet::Object -e'
481             $set = Set::Object::set (List::Util::shuffle(1..1000));
482             Benchmark::timethese(-3, {
483             "Slow \@\$set " => sub { $i++ for @$set; },
484             "Fast set->members" => sub { $i++ for $set->members(); },
485             });'
486              
487             Benchmark: running Fast set->members, Slow @$set for at least 3 CPU seconds...
488             Fast set->members: 4 wallclock secs ( 3.17 usr + 0.00 sys = 3.17 CPU) @ 9104.42/s (n=28861)
489             Slow @$set : 4 wallclock secs ( 3.23 usr + 0.00 sys = 3.23 CPU) @ 1689.16/s (n=5456)
490              
491             =head1 THREAD SAFETY
492              
493             This module is not thread-safe.
494              
495             =head1 AUTHOR
496              
497             Original Set::Object module by Jean-Louis Leroy,
498              
499             Set::Scalar compatibility, XS debugging, weak references support
500             courtesy of Sam Vilain, .
501              
502             New maintainer is Reini Urban .
503             Patches against L please.
504             Tickets at RT L
505              
506             =head1 LICENCE
507              
508             Copyright (c) 1998-1999, Jean-Louis Leroy. All Rights Reserved.
509             This module is free software. It may be used, redistributed
510             and/or modified under the terms of the Perl Artistic License, either the
511             original, or at your option, any later version.
512              
513             Portions Copyright (c) 2003 - 2005, Sam Vilain. Same license.
514              
515             Portions Copyright (c) 2006, 2007, Catalyst IT (NZ) Limited. This
516             module is free software. It may be used, redistributed and/or modified
517             under the terms of the Perl Artistic License
518              
519             Portions Copyright (c) 2013, cPanel. Same license.
520             Portions Copyright (c) 2020, Reini Urban. Same license.
521              
522             =head1 SEE ALSO
523              
524             perl(1), perltie(1), L, L
525              
526             =cut
527              
528             package Set::Object;
529              
530 40     40   450223 use strict;
  40         262  
  40         1095  
531 40     40   177 use Carp;
  40         68  
  40         3623  
532 40     40   248 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  40         88  
  40         65525  
533              
534             require Exporter;
535             require DynaLoader;
536             require AutoLoader;
537              
538             @ISA = qw(Exporter DynaLoader);
539             # Items to export into callers namespace by default. Note: do not export
540             # names by default without a very good reason. Use EXPORT_OK instead.
541             # Do not simply export all your public functions/methods/constants.
542              
543             @EXPORT_OK = qw( ish_int is_int is_string is_double blessed reftype
544             refaddr is_overloaded is_object is_key set weak_set );
545             $VERSION = '1.42';
546              
547             bootstrap Set::Object $VERSION;
548              
549             # Preloaded methods go here.
550              
551             our $cust_disp;
552              
553             sub as_string
554             {
555 128 100   128 1 25445 return $cust_disp->(@_) if $cust_disp;
556 104         141 my $self = shift;
557 104 100       457 croak "Tried to use as_string on something other than a Set::Object"
558             unless (UNIVERSAL::isa($self, __PACKAGE__));
559              
560 103         596 ref($self).'(' . (join ' ', sort { $a cmp $b }
  513         961  
561             $self->members) . ')'
562             }
563              
564             sub equal
565             {
566 42     42 1 2045 my ($s1, $s2) = @_;
567 42 100       120 return undef unless (UNIVERSAL::isa($s2, __PACKAGE__));
568              
569 38 100       250 $s1->size() == $s2->size() && $s1->includes($s2->members);
570             }
571              
572             sub not_equal
573             {
574 5     5 1 23 !shift->equal(shift);
575             }
576              
577             sub union
578             {
579             $_[0]->set
580 87         265 ( map { $_->members() }
581 44     44 1 1217 grep { UNIVERSAL::isa($_, __PACKAGE__) }
  88         208  
582             @_ );
583             }
584              
585             sub op_union
586             {
587 19     19 0 1002 my $self = shift;
588 19         23 my $other;
589 19 100       45 if (ref $_[0]) {
590 11         15 $other = shift;
591             } else {
592 8         17 $other = $self->set(shift);
593             }
594              
595 19 50 33     95 croak("Tried to form union between Set::Object & "
596             ."`$other'")
597             if ref $other and not UNIVERSAL::isa($other, __PACKAGE__);
598              
599 19         42 $self->union($other);
600              
601             }
602              
603             sub intersection
604             {
605 24     24 1 2065 my $s = shift;
606 24         73 my $rem = $s->set($s->members);
607              
608 24         188 while ($s = shift)
609             {
610 25 50       62 if (!ref $s) {
611 0         0 $s = $rem->new($s);
612             }
613              
614 25 100 33     238 croak("Tried to form intersection between Set::Object & "
615             .(ref($s)||$s)) unless UNIVERSAL::isa($s, __PACKAGE__);
616              
617 23         59 $rem->remove(grep { !$s->includes($_) } $rem->members);
  74         186  
618             }
619              
620 22         65 $rem;
621             }
622              
623             sub op_intersection
624             {
625 17     17 0 97 my $s1 = shift;
626 17         19 my $s2;
627 17 100       28 if (ref $_[0]) {
628 13         17 $s2 = shift;
629             } else {
630 4         6 $s2 = $s1->set(shift);
631             }
632 17         26 my $r = shift;
633 17 100       24 if ( $r ) {
634 2         3 return intersection($s2, $s1);
635             } else {
636 15         25 return intersection($s1, $s2);
637             }
638              
639             }
640              
641             sub difference
642             {
643 62     62 1 4124 my ($s1, $s2, $r) = @_;
644 62 100       132 if ( ! ref $s2 ) {
645 6 50 33     28 if ( is_int($s2) and !is_string($s2) and $s2 == 0 ) {
      33        
646 0         0 return __PACKAGE__->new();
647             } else {
648 6         21 my $set = __PACKAGE__->new($s2);
649 6         13 $s2 = $set;
650             }
651             }
652 62 100 33     290 croak("Tried to find difference between Set::Object & "
653             .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__);
654              
655 60         74 my $s;
656 60 100       99 if ( $r ) {
657 2         5 $s = $s2->set( grep { !$s1->includes($_) } $s2->members );
  2         8  
658             } else {
659 58         214 $s = $s1->set( grep { !$s2->includes($_) } $s1->members );
  217         512  
660             }
661 60         211 $s;
662             }
663              
664             sub op_invert
665             {
666 4     4 0 646 my $self = shift;
667 4         11 my $other;
668 4 100       10 if (ref $_[0]) {
669 1         2 $other = shift;
670             } else {
671 3         13 $other = __PACKAGE__->new(shift);
672             }
673              
674 4 50 33     29 croak("Tried to form union between Set::Object & "
675             ."`$other'")
676             if ref $other and not UNIVERSAL::isa($other, __PACKAGE__);
677              
678 4         19 my $result = $self->set( $self->members() );
679 4         31 $result->invert( $other->members() );
680 4         19 return $result;
681              
682             }
683              
684             sub op_symm_diff
685             {
686 11     11 0 555 my $self = shift;
687 11         13 my $other;
688 11 100       27 if (ref $_[0]) {
689 7         11 $other = shift;
690             } else {
691 4         15 $other = __PACKAGE__->new(shift);
692             }
693 11         24 return $self->symmetric_difference($other);
694             }
695              
696             sub unique {
697 4     4 1 64 my $self = shift;
698 4         9 $self->symmetric_difference(@_);
699             }
700              
701             sub symmetric_difference
702             {
703 19     19 1 1602 my ($s1, $s2) = @_;
704 19 100 33     223 croak("Tried to find symmetric difference between Set::Object & "
705             .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__);
706              
707 17         49 $s1->difference( $s2 )->union( $s2->difference( $s1 ) );
708             }
709              
710             sub proper_subset
711             {
712 16     16 1 2055 my ($s1, $s2) = @_;
713 16 100 33     187 croak("Tried to find proper subset of Set::Object & "
714             .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__);
715 14 100       56 $s1->size < $s2->size && $s1->subset( $s2 );
716             }
717              
718             sub subset
719             {
720 22     22 1 998 my ($s1, $s2, $r) = @_;
721 22 100 33     191 croak("Tried to find subset of Set::Object & "
722             .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__);
723 20         70 $s2->includes($s1->members);
724             }
725              
726             sub proper_superset
727             {
728 9     9 1 971 my ($s1, $s2, $r) = @_;
729 9 100 33     171 croak("Tried to find proper superset of Set::Object & "
730             .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__);
731 7         11 proper_subset( $s2, $s1 );
732             }
733              
734             sub superset
735             {
736 8     8 1 1035 my ($s1, $s2) = @_;
737 8 100 33     171 croak("Tried to find superset of Set::Object & "
738             .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__);
739 6         10 subset( $s2, $s1 );
740             }
741              
742             # following code pasted from Set::Scalar; thanks Jarkko Hietaniemi
743              
744             use overload
745             '""' => \&as_string,
746             '+' => \&op_union,
747             '*' => \&op_intersection,
748             '%' => \&op_symm_diff,
749             '/' => \&op_invert,
750             '-' => \&difference,
751             '==' => \&equal,
752             '!=' => \¬_equal,
753             '<' => \&proper_subset,
754             '>' => \&proper_superset,
755             '<=' => \&subset,
756             '>=' => \&superset,
757 0     0   0 '%{}' => sub { my $self = shift;
758 0         0 my %h = ();
759 0         0 tie %h, $self->tie_hash_pkg, [], $self;
760 0         0 \%h },
761 14     14   2616 '@{}' => sub { my $self = shift;
762 14         38 my @h = {};
763 14         31 tie @h, $self->tie_array_pkg, [], $self;
764 14         77 \@h },
765 47     47   129 'bool' => sub { 1 },
766 40         530 fallback => 1,
767 40     40   41338 ;
  40         35920  
768              
769 0     0 1 0 sub tie_hash_pkg { "Set::Object::TieHash" };
770 14     14 1 60 sub tie_array_pkg { "Set::Object::TieArray" };
771              
772             { package Set::Object::TieArray;
773             sub TIEARRAY {
774 14     14   18 my $p = shift;
775 14         33 my $tie = bless [ @_ ], $p;
776 14         74 require Scalar::Util;
777 14         54 Scalar::Util::weaken($tie->[0]);
778 14         30 Scalar::Util::weaken($tie->[1]);
779 14         32 return $tie;
780             }
781             # note the sort here
782             sub promote {
783 16     16   19 my $self = shift;
784 16         86 @{$self->[0]} = sort $self->[1]->members;
  16         50  
785 16         67 return $self->[0];
786             }
787             sub commit {
788 6     6   7 my $self = shift;
789 6         24 $self->[1]->clear;
790 6         10 $self->[1]->insert(@{$self->[0]});
  6         30  
791             }
792             sub FETCH {
793 10     10   15 my $self = shift;
794 10         13 my $index = shift;
795 10         24 $self->promote->[$index];
796             }
797             sub STORE {
798 1     1   3 my $self = shift;
799 1         2 my $index = shift;
800 1         3 $self->promote->[$index] = shift;
801 1         3 $self->commit;
802             }
803             sub FETCHSIZE {
804 5     5   9 my $self = shift;
805 5         32 return $self->[1]->size;
806             }
807             sub STORESIZE {
808 1     1   2 my $self = shift;
809 1         3 my $count = shift;
810 1         2 $#{$self->promote}=$count-1;
  1         3  
811 1         3 $self->commit;
812             }
813       0     sub EXTEND {
814             }
815             sub EXISTS {
816 1     1   3 my $self = shift;
817 1         2 my $index = shift;
818 1 50       7 if ( $index+1 > $self->[1]->size) {
819 1         5 return undef;
820             } else {
821 0         0 return 1;
822             }
823             }
824             sub DELETE {
825 1     1   3 my $self = shift;
826 1         4 delete $self->promote->[(shift)];
827 1         6 $self->commit;
828             }
829             sub PUSH {
830 1     1   2 my $self = shift;
831 1         7 $self->[1]->insert(@_);
832             }
833             sub POP {
834 1     1   3 my $self = shift;
835 1         2 my $rv = pop @{$self->promote};
  1         3  
836 1         5 $self->commit;
837 1         4 return $rv;
838             }
839             sub CLEAR {
840 0     0   0 my $self = shift;
841 0         0 $self->[1]->clear;
842             }
843             sub SHIFT {
844 1     1   2 my $self = shift;
845 1         2 my $rv = shift @{$self->promote};
  1         4  
846 1         4 $self->commit;
847 1         5 return $rv;
848             }
849             sub UNSHIFT {
850 1     1   3 my $self = shift;
851 1         7 $self->[1]->insert(@_);
852             }
853             sub SPLICE {
854 1     1   3 my $self = shift;
855 1         2 my @rv;
856             # perl5--
857 1 50       6 if ( @_ == 1 ) {
    50          
858 0         0 splice @{$self->promote}, $_[0];
  0         0  
859             }
860             elsif ( @_ == 2 ) {
861 1         3 splice @{$self->promote}, $_[0], $_[1];
  1         2  
862             }
863             else {
864 0         0 splice @{$self->promote}, $_[0], $_[1], @_;
  0         0  
865             }
866 1         4 $self->commit;
867 1         3 @rv;
868             }
869             }
870              
871             { package Set::Object::TieHash;
872             sub TIEHASH {
873 0     0   0 my $p = shift;
874 0         0 my $tie = bless [ @_ ], $p;
875 0         0 require Scalar::Util;
876 0         0 Scalar::Util::weaken($tie->[0]);
877 0         0 Scalar::Util::weaken($tie->[1]);
878 0         0 return $tie;
879             }
880             sub FETCH {
881 0     0   0 my $self = shift;
882 0         0 return $self->[1]->includes(shift);
883             }
884             sub STORE {
885 0     0   0 my $self = shift;
886 0         0 my $item = shift;
887 0 0       0 if ( shift ) {
888 0         0 $self->[1]->insert($item);
889             } else {
890 0         0 $self->[1]->remove($item);
891             }
892             }
893             sub DELETE {
894 0     0   0 my $self = shift;
895 0         0 my $item = shift;
896 0         0 $self->[1]->remove($item);
897             }
898             sub CLEAR {
899 0     0   0 my $self = shift;
900 0         0 $self->[1]->clear;
901             }
902             sub EXISTS {
903 0     0   0 my $self = shift;
904 0         0 $self->[1]->includes(shift);
905             }
906             sub FIRSTKEY {
907 0     0   0 my $self = shift;
908 0         0 @{$self->[0]} = $self->[1]->members;
  0         0  
909 0         0 $self->NEXTKEY;
910             }
911             sub NEXTKEY {
912 0     0   0 my $self = shift;
913 0 0       0 if ( @{$self->[0]} ) {
  0         0  
914 0         0 return (shift @{$self->[0]});
  0         0  
915             } else {
916 0         0 return ();
917             }
918             }
919             sub SCALAR {
920 0     0   0 my $self = shift;
921 0         0 $self->[1]->size;
922             }
923             }
924              
925             # Autoload methods go after =cut, and are processed by the autosplit program.
926             # This function is used to differentiate between an integer and a
927             # string for use by the hash container types
928              
929              
930             # This function is not from Scalar::Util; it is a DWIMy function to
931             # decide whether the passed thingy could reasonably be considered
932             # to be an array index, and if so returns the index
933             sub ish_int {
934 26     26 1 40 my $i;
935 26         41 local $@;
936 26         36 eval { $i = _ish_int($_[0]) };
  26         156  
937              
938 26 100       55 if ($@) {
939 4 100       31 if ($@ =~ /overload/i) {
    50          
940 3 100       22 if (my $sub = UNIVERSAL::can($_[0], "(0+")) {
941 1         4 return ish_int(&$sub($_[0]));
942             } else {
943 2         10 return undef;
944             }
945             } elsif ($@ =~ /tie/i) {
946 1         4 my $x = $_[0];
947 1         10 return ish_int($x);
948             }
949             } else {
950 22         113 return $i;
951             }
952             }
953              
954             # returns true if the value looks like a key, not an object or a
955             # collection
956             sub is_key {
957 15 100 100 15 1 2230 if (my $class = tied $_[0]) {
    100 100        
    100          
958 1 50       6 if ($class =~ m/^Tangram::/) { # hack for Tangram RefOnDemands
959 0         0 return undef;
960             } else {
961 1         4 my $x = $_[0];
962 1         15 return is_key($x);
963             }
964             } elsif (is_overloaded($_[0])) {
965             # this is a bit of a hack - intrude into the overload internal
966             # space
967 5 100       47 if (my $sub = UNIVERSAL::can($_[0], "(0+")) {
    100          
    50          
968 1         4 return is_key(&$sub($_[0]));
969             } elsif ($sub = UNIVERSAL::can($_[0], '(""')) {
970 2         7 return is_key(&$sub($_[0]));
971             } elsif ($sub = UNIVERSAL::can($_[0], '(nomethod')) {
972 0         0 return is_key(&$sub($_[0]));
973             } else {
974 2         10 return undef;
975             }
976             } elsif (is_int($_[0]) || is_string($_[0]) || is_double($_[0])) {
977 7         33 return 1;
978             } else {
979 2         10 return undef;
980             }
981             }
982              
983             # interface so that Storable may still work
984             sub STORABLE_freeze {
985 2005     2005 0 17131 my $obj = shift;
986 2005         2129 my $am_cloning = shift;
987 2005 100       9835 return ("v3-" . ($obj->is_weak ? "w" : "s"), [ $obj->members ]);
988             }
989              
990             #use Devel::Peek qw(Dump);
991              
992             sub STORABLE_thaw {
993             #print Dump $_ foreach (@_);
994              
995 2005 50   2005 0 3431 if ( $_[2] ) {
996 2005 50       5142 if ( $_[2] eq "v2" ) {
    50          
997 0         0 @_ = (@_[0,1], "", @{ $_[3] });
  0         0  
998             }
999             elsif ( $_[2] =~ m/^v3-(w|s)/ ) {
1000 2005         2581 @_ = (@_[0,1], "", @{ $_[3] });
  2005         3660  
1001 2005 100       3964 if ( $1 eq "w" ) {
1002 1         2 my $self = shift;
1003 1         8 $self->_STORABLE_thaw(@_);
1004 1         3 $self->weaken();
1005 1         9 return;
1006             }
1007             } else {
1008 0         0 croak("Unrecognised Set::Object Storable version $_[2]");
1009             }
1010             }
1011              
1012 2004         8735 goto &_STORABLE_thaw;
1013             #print "Got here\n";
1014             }
1015              
1016             sub delete {
1017 2     2 1 758 my $self = shift;
1018 2         13 return $self->remove(@_);
1019             }
1020              
1021             our $AUTOLOAD;
1022             sub AUTOLOAD {
1023 0     0   0 croak "No such method $AUTOLOAD";
1024             }
1025              
1026             sub invert {
1027 6     6 1 617 my $self = shift;
1028 6         18 while ( @_ ) {
1029 13         22 my $sv = shift;
1030 13 50       25 defined $sv or next;
1031 13 100       38 if ( $self->includes($sv) ) {
1032 4         16 $self->remove($sv);
1033             } else {
1034 9         31 $self->insert($sv);
1035             }
1036             }
1037             }
1038              
1039             sub compare {
1040 3     3 1 17 my $self = shift;
1041 3         4 my $other = shift;
1042              
1043 3 50       7 return "apples, oranges" unless UNIVERSAL::isa($other, __PACKAGE__);
1044              
1045 3         8 my $only_self = $self - $other;
1046 3         6 my $only_other = $other - $self;
1047 3         6 my $intersect = $self * $other;
1048              
1049 3 100       8 if ( $intersect->size ) {
1050 1 50       3 if ( $only_self->size ) {
1051 1 50       3 if ( $only_other->size ) {
1052 1         8 return "proper intersect";
1053             } else {
1054 0         0 return "proper subset";
1055             }
1056             } else {
1057 0 0       0 if ( $only_other->size ) {
1058 0         0 return "proper superset";
1059             } else {
1060 0         0 return "equal";
1061             }
1062             }
1063             } else {
1064 2 100 66     10 if ($self->size || $other->size) {
1065 1         6 return "disjoint";
1066             } else {
1067             # both sets are empty
1068 1         5 return "equal";
1069             }
1070             }
1071             }
1072              
1073             sub is_disjoint {
1074 1     1 1 5 my $self = shift;
1075 1         2 my $other = shift;
1076              
1077 1 50       3 return "apples, oranges" unless UNIVERSAL::isa($other, __PACKAGE__);
1078 1         2 return !($self*$other)->size;
1079             }
1080              
1081             #use Data::Dumper;
1082             sub as_string_callback {
1083 6     6 1 36 shift;
1084 6 100       17 if ( @_ ) {
1085 5         9 $cust_disp = shift;
1086 5 100 100     28 if ( $cust_disp &&
1087             $cust_disp == \&as_string ) {
1088 1         3 undef($cust_disp);
1089             }
1090             } else {
1091 1         3 \&as_string;
1092             }
1093             }
1094              
1095             sub elements {
1096 4     4 1 14 my $self = shift;
1097 4         68 return $self->members(@_);
1098             }
1099              
1100 2     2 1 44 sub has { (shift)->includes(@_) }
1101 1     1 1 9 sub contains { (shift)->includes(@_) }
1102 1     1 1 6 sub element { (shift)->member(@_) }
1103             sub member {
1104 3     3 1 26 my $self = shift;
1105 3         4 my $item = shift;
1106 3 100       12 return ( $self->includes($item) ?
1107             $item : undef );
1108             }
1109              
1110             sub set {
1111 145     145 1 7544 local $@;
1112 145 100       210 if (eval { $_[0]->isa(__PACKAGE__) }) {
  145         574  
1113 134         177 shift;
1114             }
1115 145         763 __PACKAGE__->new(@_);
1116             }
1117             sub weak_set {
1118 4     4 1 991 my $self = __PACKAGE__->new();
1119 4         11 $self->weaken;
1120 4         18 $self->insert(@_);
1121 4         12 return $self;
1122             }
1123              
1124             require Set::Object::Weak;
1125             sub weaken {
1126 19     19 1 3984 my $self = shift;
1127 19         54 $self->_weaken;
1128 19         32 bless $self, $self->weak_pkg;
1129             }
1130              
1131             sub strengthen {
1132 1     1 1 1143 my $self = shift;
1133 1         7 $self->_strengthen;
1134 1         5 bless $self, $self->strong_pkg;
1135             }
1136              
1137             sub weak_pkg {
1138 19     19 1 39 "Set::Object::Weak";
1139             }
1140             sub strong_pkg {
1141 7     7 1 16 "Set::Object";
1142             }
1143             1;
1144              
1145             __END__