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             =head1 THREAD SAFETY
479              
480             This module is not thread-safe.
481              
482             =head1 AUTHOR
483              
484             Original Set::Object module by Jean-Louis Leroy,
485              
486             Set::Scalar compatibility, XS debugging, weak references support
487             courtesy of Sam Vilain, .
488              
489             New maintainer is Reini Urban .
490             Patches against L please.
491             Tickets at RT L
492              
493             =head1 LICENCE
494              
495             Copyright (c) 1998-1999, Jean-Louis Leroy. All Rights Reserved.
496             This module is free software. It may be used, redistributed
497             and/or modified under the terms of the Perl Artistic License, either the
498             original, or at your option, any later version.
499              
500             Portions Copyright (c) 2003 - 2005, Sam Vilain. Same license.
501              
502             Portions Copyright (c) 2006, 2007, Catalyst IT (NZ) Limited. This
503             module is free software. It may be used, redistributed and/or modified
504             under the terms of the Perl Artistic License
505              
506             Portions Copyright (c) 2013, cPanel. Same license.
507             Portions Copyright (c) 2020, Reini Urban. Same license.
508              
509             =head1 SEE ALSO
510              
511             perl(1), perltie(1), L, L
512              
513             =cut
514              
515             package Set::Object;
516              
517 40     40   460690 use strict;
  40         265  
  40         1058  
518 40     40   195 use Carp;
  40         63  
  40         3934  
519 40     40   231 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  40         70  
  40         61525  
520              
521             require Exporter;
522             require DynaLoader;
523             require AutoLoader;
524              
525             @ISA = qw(Exporter DynaLoader);
526             # Items to export into callers namespace by default. Note: do not export
527             # names by default without a very good reason. Use EXPORT_OK instead.
528             # Do not simply export all your public functions/methods/constants.
529              
530             @EXPORT_OK = qw( ish_int is_int is_string is_double blessed reftype
531             refaddr is_overloaded is_object is_key set weak_set );
532             $VERSION = '1.41';
533              
534             bootstrap Set::Object $VERSION;
535              
536             # Preloaded methods go here.
537              
538             our $cust_disp;
539              
540             sub as_string
541             {
542 128 100   128 1 41745 return $cust_disp->(@_) if $cust_disp;
543 104         144 my $self = shift;
544 104 100       427 croak "Tried to use as_string on something other than a Set::Object"
545             unless (UNIVERSAL::isa($self, __PACKAGE__));
546              
547 103         608 ref($self).'(' . (join ' ', sort { $a cmp $b }
  468         837  
548             $self->members) . ')'
549             }
550              
551             sub equal
552             {
553 42     42 1 2081 my ($s1, $s2) = @_;
554 42 100       119 return undef unless (UNIVERSAL::isa($s2, __PACKAGE__));
555              
556 38 100       263 $s1->size() == $s2->size() && $s1->includes($s2->members);
557             }
558              
559             sub not_equal
560             {
561 5     5 1 27 !shift->equal(shift);
562             }
563              
564             sub union
565             {
566             $_[0]->set
567 87         259 ( map { $_->members() }
568 44     44 1 1189 grep { UNIVERSAL::isa($_, __PACKAGE__) }
  88         203  
569             @_ );
570             }
571              
572             sub op_union
573             {
574 19     19 0 1108 my $self = shift;
575 19         24 my $other;
576 19 100       40 if (ref $_[0]) {
577 11         16 $other = shift;
578             } else {
579 8         14 $other = $self->set(shift);
580             }
581              
582 19 50 33     99 croak("Tried to form union between Set::Object & "
583             ."`$other'")
584             if ref $other and not UNIVERSAL::isa($other, __PACKAGE__);
585              
586 19         35 $self->union($other);
587              
588             }
589              
590             sub intersection
591             {
592 24     24 1 2094 my $s = shift;
593 24         77 my $rem = $s->set($s->members);
594              
595 24         175 while ($s = shift)
596             {
597 25 50       50 if (!ref $s) {
598 0         0 $s = $rem->new($s);
599             }
600              
601 25 100 33     237 croak("Tried to form intersection between Set::Object & "
602             .(ref($s)||$s)) unless UNIVERSAL::isa($s, __PACKAGE__);
603              
604 23         58 $rem->remove(grep { !$s->includes($_) } $rem->members);
  74         188  
605             }
606              
607 22         68 $rem;
608             }
609              
610             sub op_intersection
611             {
612 17     17 0 107 my $s1 = shift;
613 17         18 my $s2;
614 17 100       35 if (ref $_[0]) {
615 13         16 $s2 = shift;
616             } else {
617 4         5 $s2 = $s1->set(shift);
618             }
619 17         20 my $r = shift;
620 17 100       35 if ( $r ) {
621 2         5 return intersection($s2, $s1);
622             } else {
623 15         32 return intersection($s1, $s2);
624             }
625              
626             }
627              
628             sub difference
629             {
630 62     62 1 4375 my ($s1, $s2, $r) = @_;
631 62 100       132 if ( ! ref $s2 ) {
632 6 50 33     24 if ( is_int($s2) and !is_string($s2) and $s2 == 0 ) {
      33        
633 0         0 return __PACKAGE__->new();
634             } else {
635 6         18 my $set = __PACKAGE__->new($s2);
636 6         10 $s2 = $set;
637             }
638             }
639 62 100 33     285 croak("Tried to find difference between Set::Object & "
640             .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__);
641              
642 60         68 my $s;
643 60 100       90 if ( $r ) {
644 2         5 $s = $s2->set( grep { !$s1->includes($_) } $s2->members );
  2         8  
645             } else {
646 58         196 $s = $s1->set( grep { !$s2->includes($_) } $s1->members );
  217         456  
647             }
648 60         201 $s;
649             }
650              
651             sub op_invert
652             {
653 4     4 0 734 my $self = shift;
654 4         6 my $other;
655 4 100       10 if (ref $_[0]) {
656 1         2 $other = shift;
657             } else {
658 3         9 $other = __PACKAGE__->new(shift);
659             }
660              
661 4 50 33     62 croak("Tried to form union between Set::Object & "
662             ."`$other'")
663             if ref $other and not UNIVERSAL::isa($other, __PACKAGE__);
664              
665 4         20 my $result = $self->set( $self->members() );
666 4         26 $result->invert( $other->members() );
667 4         15 return $result;
668              
669             }
670              
671             sub op_symm_diff
672             {
673 11     11 0 565 my $self = shift;
674 11         13 my $other;
675 11 100       27 if (ref $_[0]) {
676 7         10 $other = shift;
677             } else {
678 4         13 $other = __PACKAGE__->new(shift);
679             }
680 11         21 return $self->symmetric_difference($other);
681             }
682              
683             sub unique {
684 4     4 1 45 my $self = shift;
685 4         7 $self->symmetric_difference(@_);
686             }
687              
688             sub symmetric_difference
689             {
690 19     19 1 1541 my ($s1, $s2) = @_;
691 19 100 33     222 croak("Tried to find symmetric difference between Set::Object & "
692             .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__);
693              
694 17         37 $s1->difference( $s2 )->union( $s2->difference( $s1 ) );
695             }
696              
697             sub proper_subset
698             {
699 16     16 1 2059 my ($s1, $s2) = @_;
700 16 100 33     183 croak("Tried to find proper subset of Set::Object & "
701             .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__);
702 14 100       44 $s1->size < $s2->size && $s1->subset( $s2 );
703             }
704              
705             sub subset
706             {
707 22     22 1 1010 my ($s1, $s2, $r) = @_;
708 22 100 33     188 croak("Tried to find subset of Set::Object & "
709             .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__);
710 20         69 $s2->includes($s1->members);
711             }
712              
713             sub proper_superset
714             {
715 9     9 1 972 my ($s1, $s2, $r) = @_;
716 9 100 33     168 croak("Tried to find proper superset of Set::Object & "
717             .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__);
718 7         11 proper_subset( $s2, $s1 );
719             }
720              
721             sub superset
722             {
723 8     8 1 1017 my ($s1, $s2) = @_;
724 8 100 33     166 croak("Tried to find superset of Set::Object & "
725             .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__);
726 6         10 subset( $s2, $s1 );
727             }
728              
729             # following code pasted from Set::Scalar; thanks Jarkko Hietaniemi
730              
731             use overload
732             '""' => \&as_string,
733             '+' => \&op_union,
734             '*' => \&op_intersection,
735             '%' => \&op_symm_diff,
736             '/' => \&op_invert,
737             '-' => \&difference,
738             '==' => \&equal,
739             '!=' => \¬_equal,
740             '<' => \&proper_subset,
741             '>' => \&proper_superset,
742             '<=' => \&subset,
743             '>=' => \&superset,
744 0     0   0 '%{}' => sub { my $self = shift;
745 0         0 my %h = {};
746 0         0 tie %h, $self->tie_hash_pkg, [], $self;
747 0         0 \%h },
748 14     14   2591 '@{}' => sub { my $self = shift;
749 14         35 my @h = {};
750 14         35 tie @h, $self->tie_array_pkg, [], $self;
751 14         72 \@h },
752 47     47   130 'bool' => sub { 1 },
753 40         510 fallback => 1,
754 40     40   42469 ;
  40         36224  
755              
756 0     0 1 0 sub tie_hash_pkg { "Set::Object::TieHash" };
757 14     14 1 54 sub tie_array_pkg { "Set::Object::TieArray" };
758              
759             { package Set::Object::TieArray;
760             sub TIEARRAY {
761 14     14   26 my $p = shift;
762 14         32 my $tie = bless [ @_ ], $p;
763 14         70 require Scalar::Util;
764 14         62 Scalar::Util::weaken($tie->[0]);
765 14         29 Scalar::Util::weaken($tie->[1]);
766 14         29 return $tie;
767             }
768             # note the sort here
769             sub promote {
770 16     16   20 my $self = shift;
771 16         81 @{$self->[0]} = sort $self->[1]->members;
  16         55  
772 16         61 return $self->[0];
773             }
774             sub commit {
775 6     6   12 my $self = shift;
776 6         21 $self->[1]->clear;
777 6         8 $self->[1]->insert(@{$self->[0]});
  6         31  
778             }
779             sub FETCH {
780 10     10   14 my $self = shift;
781 10         13 my $index = shift;
782 10         21 $self->promote->[$index];
783             }
784             sub STORE {
785 1     1   3 my $self = shift;
786 1         2 my $index = shift;
787 1         3 $self->promote->[$index] = shift;
788 1         3 $self->commit;
789             }
790             sub FETCHSIZE {
791 5     5   9 my $self = shift;
792 5         30 return $self->[1]->size;
793             }
794             sub STORESIZE {
795 1     1   3 my $self = shift;
796 1         2 my $count = shift;
797 1         3 $#{$self->promote}=$count-1;
  1         3  
798 1         3 $self->commit;
799             }
800       0     sub EXTEND {
801             }
802             sub EXISTS {
803 1     1   3 my $self = shift;
804 1         3 my $index = shift;
805 1 50       6 if ( $index+1 > $self->[1]->size) {
806 1         6 return undef;
807             } else {
808 0         0 return 1;
809             }
810             }
811             sub DELETE {
812 1     1   3 my $self = shift;
813 1         4 delete $self->promote->[(shift)];
814 1         3 $self->commit;
815             }
816             sub PUSH {
817 1     1   3 my $self = shift;
818 1         8 $self->[1]->insert(@_);
819             }
820             sub POP {
821 1     1   2 my $self = shift;
822 1         2 my $rv = pop @{$self->promote};
  1         3  
823 1         4 $self->commit;
824 1         4 return $rv;
825             }
826             sub CLEAR {
827 0     0   0 my $self = shift;
828 0         0 $self->[1]->clear;
829             }
830             sub SHIFT {
831 1     1   3 my $self = shift;
832 1         2 my $rv = shift @{$self->promote};
  1         3  
833 1         4 $self->commit;
834 1         5 return $rv;
835             }
836             sub UNSHIFT {
837 1     1   3 my $self = shift;
838 1         6 $self->[1]->insert(@_);
839             }
840             sub SPLICE {
841 1     1   3 my $self = shift;
842 1         2 my @rv;
843             # perl5--
844 1 50       6 if ( @_ == 1 ) {
    50          
845 0         0 splice @{$self->promote}, $_[0];
  0         0  
846             }
847             elsif ( @_ == 2 ) {
848 1         2 splice @{$self->promote}, $_[0], $_[1];
  1         3  
849             }
850             else {
851 0         0 splice @{$self->promote}, $_[0], $_[1], @_;
  0         0  
852             }
853 1         4 $self->commit;
854 1         3 @rv;
855             }
856             }
857              
858             { package Set::Object::TieHash;
859             sub TIEHASH {
860 0     0   0 my $p = shift;
861 0         0 my $tie = bless [ @_ ], $p;
862 0         0 require Scalar::Util;
863 0         0 Scalar::Util::weaken($tie->[0]);
864 0         0 Scalar::Util::weaken($tie->[1]);
865 0         0 return $tie;
866             }
867             sub FETCH {
868 0     0   0 my $self = shift;
869 0         0 return $self->[1]->includes(shift);
870             }
871             sub STORE {
872 0     0   0 my $self = shift;
873 0         0 my $item = shift;
874 0 0       0 if ( shift ) {
875 0         0 $self->[1]->insert($item);
876             } else {
877 0         0 $self->[1]->remove($item);
878             }
879             }
880             sub DELETE {
881 0     0   0 my $self = shift;
882 0         0 my $item = shift;
883 0         0 $self->[1]->remove($item);
884             }
885             sub CLEAR {
886 0     0   0 my $self = shift;
887 0         0 $self->[1]->clear;
888             }
889             sub EXISTS {
890 0     0   0 my $self = shift;
891 0         0 $self->[1]->includes(shift);
892             }
893             sub FIRSTKEY {
894 0     0   0 my $self = shift;
895 0         0 @{$self->[0]} = $self->[1]->members;
  0         0  
896 0         0 $self->NEXTKEY;
897             }
898             sub NEXTKEY {
899 0     0   0 my $self = shift;
900 0 0       0 if ( @{$self->[0]} ) {
  0         0  
901 0         0 return (shift @{$self->[0]});
  0         0  
902             } else {
903 0         0 return ();
904             }
905             }
906             sub SCALAR {
907 0     0   0 my $self = shift;
908 0         0 $self->[1]->size;
909             }
910             }
911              
912             # Autoload methods go after =cut, and are processed by the autosplit program.
913             # This function is used to differentiate between an integer and a
914             # string for use by the hash container types
915              
916              
917             # This function is not from Scalar::Util; it is a DWIMy function to
918             # decide whether the passed thingy could reasonably be considered
919             # to be an array index, and if so returns the index
920             sub ish_int {
921 26     26 1 42 my $i;
922 26         35 local $@;
923 26         35 eval { $i = _ish_int($_[0]) };
  26         88  
924              
925 26 100       52 if ($@) {
926 4 100       24 if ($@ =~ /overload/i) {
    50          
927 3 100       18 if (my $sub = UNIVERSAL::can($_[0], "(0+")) {
928 1         3 return ish_int(&$sub($_[0]));
929             } else {
930 2         9 return undef;
931             }
932             } elsif ($@ =~ /tie/i) {
933 1         5 my $x = $_[0];
934 1         7 return ish_int($x);
935             }
936             } else {
937 22         106 return $i;
938             }
939             }
940              
941             # returns true if the value looks like a key, not an object or a
942             # collection
943             sub is_key {
944 15 100 100 15 1 2219 if (my $class = tied $_[0]) {
    100 100        
    100          
945 1 50       6 if ($class =~ m/^Tangram::/) { # hack for Tangram RefOnDemands
946 0         0 return undef;
947             } else {
948 1         3 my $x = $_[0];
949 1         7 return is_key($x);
950             }
951             } elsif (is_overloaded($_[0])) {
952             # this is a bit of a hack - intrude into the overload internal
953             # space
954 5 100       40 if (my $sub = UNIVERSAL::can($_[0], "(0+")) {
    100          
    50          
955 1         3 return is_key(&$sub($_[0]));
956             } elsif ($sub = UNIVERSAL::can($_[0], '(""')) {
957 2         7 return is_key(&$sub($_[0]));
958             } elsif ($sub = UNIVERSAL::can($_[0], '(nomethod')) {
959 0         0 return is_key(&$sub($_[0]));
960             } else {
961 2         8 return undef;
962             }
963             } elsif (is_int($_[0]) || is_string($_[0]) || is_double($_[0])) {
964 7         29 return 1;
965             } else {
966 2         9 return undef;
967             }
968             }
969              
970             # interface so that Storable may still work
971             sub STORABLE_freeze {
972 2005     2005 0 16924 my $obj = shift;
973 2005         1811 my $am_cloning = shift;
974 2005 100       8834 return ("v3-" . ($obj->is_weak ? "w" : "s"), [ $obj->members ]);
975             }
976              
977             #use Devel::Peek qw(Dump);
978              
979             sub STORABLE_thaw {
980             #print Dump $_ foreach (@_);
981              
982 2005 50   2005 0 3067 if ( $_[2] ) {
983 2005 50       5142 if ( $_[2] eq "v2" ) {
    50          
984 0         0 @_ = (@_[0,1], "", @{ $_[3] });
  0         0  
985             }
986             elsif ( $_[2] =~ m/^v3-(w|s)/ ) {
987 2005         2605 @_ = (@_[0,1], "", @{ $_[3] });
  2005         3202  
988 2005 100       3568 if ( $1 eq "w" ) {
989 1         2 my $self = shift;
990 1         9 $self->_STORABLE_thaw(@_);
991 1         4 $self->weaken();
992 1         9 return;
993             }
994             } else {
995 0         0 croak("Unrecognised Set::Object Storable version $_[2]");
996             }
997             }
998              
999 2004         8906 goto &_STORABLE_thaw;
1000             #print "Got here\n";
1001             }
1002              
1003             sub delete {
1004 2     2 1 1248 my $self = shift;
1005 2         12 return $self->remove(@_);
1006             }
1007              
1008             our $AUTOLOAD;
1009             sub AUTOLOAD {
1010 0     0   0 croak "No such method $AUTOLOAD";
1011             }
1012              
1013             sub invert {
1014 6     6 1 697 my $self = shift;
1015 6         17 while ( @_ ) {
1016 13         17 my $sv = shift;
1017 13 50       22 defined $sv or next;
1018 13 100       32 if ( $self->includes($sv) ) {
1019 4         14 $self->remove($sv);
1020             } else {
1021 9         36 $self->insert($sv);
1022             }
1023             }
1024             }
1025              
1026             sub compare {
1027 3     3 1 17 my $self = shift;
1028 3         3 my $other = shift;
1029              
1030 3 50       8 return "apples, oranges" unless UNIVERSAL::isa($other, __PACKAGE__);
1031              
1032 3         5 my $only_self = $self - $other;
1033 3         6 my $only_other = $other - $self;
1034 3         5 my $intersect = $self * $other;
1035              
1036 3 100       8 if ( $intersect->size ) {
1037 1 50       3 if ( $only_self->size ) {
1038 1 50       3 if ( $only_other->size ) {
1039 1         9 return "proper intersect";
1040             } else {
1041 0         0 return "proper subset";
1042             }
1043             } else {
1044 0 0       0 if ( $only_other->size ) {
1045 0         0 return "proper superset";
1046             } else {
1047 0         0 return "equal";
1048             }
1049             }
1050             } else {
1051 2 100 66     18 if ($self->size || $other->size) {
1052 1         8 return "disjoint";
1053             } else {
1054             # both sets are empty
1055 1         4 return "equal";
1056             }
1057             }
1058             }
1059              
1060             sub is_disjoint {
1061 1     1 1 5 my $self = shift;
1062 1         2 my $other = shift;
1063              
1064 1 50       3 return "apples, oranges" unless UNIVERSAL::isa($other, __PACKAGE__);
1065 1         2 return !($self*$other)->size;
1066             }
1067              
1068             #use Data::Dumper;
1069             sub as_string_callback {
1070 6     6 1 29 shift;
1071 6 100       13 if ( @_ ) {
1072 5         9 $cust_disp = shift;
1073 5 100 100     23 if ( $cust_disp &&
1074             $cust_disp == \&as_string ) {
1075 1         3 undef($cust_disp);
1076             }
1077             } else {
1078 1         2 \&as_string;
1079             }
1080             }
1081              
1082             sub elements {
1083 4     4 1 12 my $self = shift;
1084 4         24 return $self->members(@_);
1085             }
1086              
1087 2     2 1 31 sub has { (shift)->includes(@_) }
1088 1     1 1 8 sub contains { (shift)->includes(@_) }
1089 1     1 1 7 sub element { (shift)->member(@_) }
1090             sub member {
1091 3     3 1 34 my $self = shift;
1092 3         5 my $item = shift;
1093 3 100       15 return ( $self->includes($item) ?
1094             $item : undef );
1095             }
1096              
1097             sub set {
1098 145     145 1 9119 local $@;
1099 145 100       202 if (eval { $_[0]->isa(__PACKAGE__) }) {
  145         537  
1100 134         167 shift;
1101             }
1102 145         705 __PACKAGE__->new(@_);
1103             }
1104             sub weak_set {
1105 4     4 1 1139 my $self = __PACKAGE__->new();
1106 4         13 $self->weaken;
1107 4         17 $self->insert(@_);
1108 4         11 return $self;
1109             }
1110              
1111             require Set::Object::Weak;
1112             sub weaken {
1113 19     19 1 5250 my $self = shift;
1114 19         56 $self->_weaken;
1115 19         34 bless $self, $self->weak_pkg;
1116             }
1117              
1118             sub strengthen {
1119 1     1 1 1487 my $self = shift;
1120 1         8 $self->_strengthen;
1121 1         4 bless $self, $self->strong_pkg;
1122             }
1123              
1124             sub weak_pkg {
1125 19     19 1 39 "Set::Object::Weak";
1126             }
1127             sub strong_pkg {
1128 7     7 1 16 "Set::Object";
1129             }
1130             1;
1131              
1132             __END__