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 |
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__ |