Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | |
2 | =head1 NAME | |
3 | ||
4 | Set::Object - set of objects | |
5 | ||
6 | =head1 SYNOPSIS | |
7 | ||
8 | use Set::Object; | |
9 | $set = Set::Object->new(); | |
10 | ||
11 | =head1 DESCRIPTION | |
12 | ||
13 | This modules implements a set of objects, that is, an unordered | |
14 | collection of objects without duplication. | |
15 | ||
16 | =head1 CLASS METHODS | |
17 | ||
18 | =head2 new( [I<list>] ) | |
19 | ||
20 | Return a new C<Set::Object> containing the elements passed in I<list>. | |
21 | The elements must be objects. | |
22 | ||
23 | =head1 INSTANCE METHODS | |
24 | ||
25 | =head2 insert( [I<list>] ) | |
26 | ||
27 | Add objects to the C<Set::Object>. | |
28 | Adding the same object several times is not an error, | |
29 | but any C<Set::Object> will contain at most one occurence of the | |
30 | same object. | |
31 | Returns the number of elements that were actually added. | |
32 | ||
33 | =head2 includes( [I<list>] ) | |
34 | ||
35 | Return C<true> if all the objects in I<list> are members of the C<Set::Object>. | |
36 | I<list> may be empty, in which case C<true> is returned. | |
37 | ||
38 | =head2 members | |
39 | ||
40 | Return the objects contained in the C<Set::Object>. | |
41 | ||
42 | =head2 size | |
43 | ||
44 | Return the number of elements in the C<Set::Object>. | |
45 | ||
46 | =head2 remove( [I<list>] ) | |
47 | ||
48 | Remove objects from a C<Set::Object>. | |
49 | Removing the same object more than once, or removing an object | |
50 | absent from the C<Set::Object> is not an error. | |
51 | Returns the number of elements that were actually removed. | |
52 | ||
53 | =head2 clear | |
54 | ||
55 | Empty this C<Set::Object>. | |
56 | ||
57 | =head2 as_string | |
58 | ||
59 | Return a textual Smalltalk-ish representation of the C<Set::Object>. | |
60 | Also available as overloaded operator "". | |
61 | ||
62 | =head2 intersection( [I<list>] ) | |
63 | ||
64 | Return a new C<Set::Object> containing the intersection of the | |
65 | C<Set::Object>s passed as arguments. | |
66 | Also available as overloaded operator *. | |
67 | ||
68 | =head2 union( [I<list>] ) | |
69 | ||
70 | Return a new C<Set::Object> containing the union of the | |
71 | C<Set::Object>s passed as arguments. | |
72 | Also available as overloaded operator +. | |
73 | ||
74 | =head2 subset( I<set> ) | |
75 | ||
76 | Return C<true> if this C<Set::Object> is a subset of I<set>. | |
77 | Also available as operator <=. | |
78 | ||
79 | =head2 proper_subset( I<set> ) | |
80 | ||
81 | Return C<true> if this C<Set::Object> is a proper subset of I<set> | |
82 | Also available as operator <. | |
83 | ||
84 | =head2 superset( I<set> ) | |
85 | ||
86 | Return C<true> if this C<Set::Object> is a superset of I<set>. | |
87 | Also available as operator >=. | |
88 | ||
89 | =head2 proper_superset( I<set> ) | |
90 | ||
91 | Return C<true> if this C<Set::Object> is a proper superset of I<set> | |
92 | Also available as operator >. | |
93 | ||
94 | =head1 FUNCTIONS | |
95 | ||
96 | The following functions are defined by the Set::Object XS code for | |
97 | convenience; they are largely identical to the versions in the | |
98 | Scalar::Util module, but there are a couple that provide functions not | |
99 | catered to by that module. | |
100 | ||
101 | =over | |
102 | ||
103 | =item B<blessed> | |
104 | ||
105 | Returns a true value if the passed reference (RV) is blessed. See | |
106 | also L<Acme::Holy>. | |
107 | ||
108 | =item B<reftype> | |
109 | ||
110 | A bit like the perl built-in C<ref> function, but returns the I<type> | |
111 | of reference; ie, if the reference is blessed then it returns what | |
112 | C<ref> would have if it were not blessed. Useful for "seeing through" | |
113 | blessed references. | |
114 | ||
115 | =item B<refaddr> | |
116 | ||
117 | Returns the memory address of a scalar. B<Warning>: this is I<not> | |
118 | guaranteed to be unique for scalars created in a program; memory might | |
119 | get re-used! | |
120 | ||
121 | =item B<is_int>, B<is_string>, B<is_double> | |
122 | ||
123 | A quick way of checking the three bits on scalars - IOK (is_int), NOK | |
124 | (is_double) and POK (is_string). Note that the exact behaviour of | |
125 | when these bits get set is not defined by the perl API. | |
126 | ||
127 | This function returns the "p" versions of the macro (SvIOKp, etc); use | |
128 | with caution. | |
129 | ||
130 | =item B<is_overloaded> | |
131 | ||
132 | A quick way to check if an object has overload magic on it. | |
133 | ||
134 | =item B<ish_int> | |
135 | ||
136 | This function returns true, if the value it is passed looks like it | |
137 | I<already is> a representation of an I<integer>. This is so that you | |
138 | can decide whether the value passed is a hash key or an array | |
139 | index... <devious grin>. | |
140 | ||
141 | =item B<is_key> | |
142 | ||
143 | This function returns true, if the value it is passed looks more like | |
144 | an I<index> to a collection than a I<value> of a collection. | |
145 | ||
146 | But wait, you say - Set::Object has no indices, one of the fundamental | |
147 | properties of a Set is that it is an I<unordered collection>. Which | |
148 | means I<no indices>. Stay tuned for the answer. | |
149 | ||
150 | =back | |
151 | ||
152 | =head1 INSTALLATION | |
153 | ||
154 | This module is partly written in C, so you'll need a C compiler to | |
155 | install it. Use the familiar sequence: | |
156 | ||
157 | perl Makefile.PL | |
158 | make | |
159 | make test | |
160 | make install | |
161 | ||
162 | This module was developed on Windows NT 4.0, using the Visual C++ | |
163 | compiler with Service Pack 2. It was also tested on AIX using IBM's | |
164 | xlc compiler. | |
165 | ||
166 | =head1 PERFORMANCE | |
167 | ||
168 | The following benchmark compares C<Set::Object> with using a hash to | |
169 | emulate a set-like collection: | |
170 | ||
171 | use Set::Object; | |
172 | ||
173 | package Obj; | |
174 | sub new { bless { } } | |
175 | ||
176 | @els = map { Obj->new() } 1..1000; | |
177 | ||
178 | require Benchmark; | |
179 | ||
180 | Benchmark::timethese(100, { | |
181 | 'Control' => sub { }, | |
182 | 'H insert' => sub { my %h = (); @h{@els} = @els; }, | |
183 | 'S insert' => sub { my $s = Set::Object->new(); $s->insert(@els) }, | |
184 | } ); | |
185 | ||
186 | %gh = (); | |
187 | @gh{@els} = @els; | |
188 | ||
189 | $gs = Set::Object->new(@els); | |
190 | $el = $els[33]; | |
191 | ||
192 | Benchmark::timethese(100_000, { | |
193 | 'H lookup' => sub { exists $gh{33} }, | |
194 | 'S lookup' => sub { $gs->includes($el) } | |
195 | } ); | |
196 | ||
197 | On my computer the results are: | |
198 | ||
199 | Benchmark: timing 100 iterations of Control, H insert, S insert... | |
200 | Control: 0 secs ( 0.01 usr 0.00 sys = 0.01 cpu) | |
201 | (warning: too few iterations for a reliable count) | |
202 | H insert: 68 secs (67.81 usr 0.00 sys = 67.81 cpu) | |
203 | S insert: 9 secs ( 8.81 usr 0.00 sys = 8.81 cpu) | |
204 | Benchmark: timing 100000 iterations of H lookup, S lookup... | |
205 | H lookup: 7 secs ( 7.14 usr 0.00 sys = 7.14 cpu) | |
206 | S lookup: 6 secs ( 5.94 usr 0.00 sys = 5.94 cpu) | |
207 | ||
208 | =head1 AUTHOR | |
209 | ||
210 | Original Set::Object module by Jean-Louis Leroy, <jll@skynet.be> | |
211 | ||
212 | =head1 LICENCE | |
213 | ||
214 | Copyright (c) 1998-1999, Jean-Louis Leroy. All Rights Reserved. | |
215 | This module is free software. It may be used, redistributed | |
216 | and/or modified under the terms of the Perl Artistic License | |
217 | ||
218 | Portions Copyright (c) 2003, Sam Vilain. All Rights Reserved. | |
219 | This module is free software. It may be used, redistributed | |
220 | and/or modified under the terms of the Perl Artistic License | |
221 | ||
222 | =head1 SEE ALSO | |
223 | ||
224 | perl(1), perltie(1), overload.pm | |
225 | ||
226 | =cut | |
227 | ||
228 | package Set::Object; | |
229 | ||
230 | use strict; | |
231 | use Carp; | |
232 | use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
233 | ||
234 | require Exporter; | |
235 | require DynaLoader; | |
236 | require AutoLoader; | |
237 | ||
238 | @ISA = qw(Exporter DynaLoader); | |
239 | # Items to export into callers namespace by default. Note: do not export | |
240 | # names by default without a very good reason. Use EXPORT_OK instead. | |
241 | # Do not simply export all your public functions/methods/constants. | |
242 | ||
243 | @EXPORT_OK = qw( ish_int is_int is_string is_double blessed reftype | |
244 | refaddr is_overloaded is_object is_key ); | |
245 | $VERSION = '1.05'; | |
246 | ||
247 | bootstrap Set::Object $VERSION; | |
248 | ||
249 | # Preloaded methods go here. | |
250 | ||
251 | sub as_string | |
252 | { | |
253 | my $self = shift; | |
254 | croak "Tried to use as_string on something other than a Set::Object" | |
255 | unless (UNIVERSAL::isa($self, __PACKAGE__)); | |
256 | ||
257 | 'Set::Object(' . (join ' ', $self->members) . ')' | |
258 | } | |
259 | ||
260 | sub equal | |
261 | { | |
262 | my ($s1, $s2) = @_; | |
263 | return undef unless (UNIVERSAL::isa($s2, __PACKAGE__)); | |
264 | ||
265 | $s1->size() == $s2->size() && $s1->includes($s2->members); | |
266 | } | |
267 | ||
268 | sub not_equal | |
269 | { | |
270 | !shift->equal(shift); | |
271 | } | |
272 | ||
273 | sub union | |
274 | { | |
275 | Set::Object->new( map { $_->members() } | |
276 | grep { UNIVERSAL::isa($_, __PACKAGE__) } | |
277 | @_ ) | |
278 | } | |
279 | ||
280 | sub op_union | |
281 | { | |
282 | croak("Tried to form union between Set::Object & " | |
283 | .(ref($_[1])||$_[1])) | |
284 | unless UNIVERSAL::isa($_[1], __PACKAGE__); | |
285 | ||
286 | Set::Object->new( shift->members(), shift->members() ) | |
287 | } | |
288 | ||
289 | sub intersection | |
290 | { | |
291 | my $s = shift; | |
292 | return Set::Object->new() unless $s; | |
293 | ||
294 | my @r = $s->members; | |
295 | ||
296 | while (@r && ($s = shift)) | |
297 | { | |
298 | croak("Tried to form intersection between Set::Object & " | |
299 | .(ref($s)||$s)) unless UNIVERSAL::isa($s, __PACKAGE__); | |
300 | ||
301 | @r = grep { $s->includes( $_ ) } @r; | |
302 | } | |
303 | ||
304 | Set::Object->new( @r ); | |
305 | } | |
306 | ||
307 | sub op_intersection | |
308 | { | |
309 | goto &intersection; | |
310 | } | |
311 | ||
312 | sub difference | |
313 | { | |
314 | my ($s1, $s2, $r) = @_; | |
315 | croak("Tried to find difference between Set::Object & " | |
316 | .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__); | |
317 | ||
318 | Set::Object->new( grep { !$s2->includes($_) } $s1->members ); | |
319 | } | |
320 | ||
321 | sub symmetric_difference | |
322 | { | |
323 | my ($s1, $s2) = @_; | |
324 | croak("Tried to find symmetric difference between Set::Object & " | |
325 | .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__); | |
326 | ||
327 | $s1->difference( $s2 )->union( $s2->difference( $s1 ) ); | |
328 | } | |
329 | ||
330 | sub proper_subset | |
331 | { | |
332 | my ($s1, $s2) = @_; | |
333 | croak("Tried to find proper subset of Set::Object & " | |
334 | .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__); | |
335 | $s1->size < $s2->size && $s1->subset( $s2 ); | |
336 | } | |
337 | ||
338 | sub subset | |
339 | { | |
340 | my ($s1, $s2, $r) = @_; | |
341 | croak("Tried to find subset of Set::Object & " | |
342 | .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__); | |
343 | $s2->includes($s1->members); | |
344 | } | |
345 | ||
346 | sub proper_superset | |
347 | { | |
348 | my ($s1, $s2, $r) = @_; | |
349 | croak("Tried to find proper superset of Set::Object & " | |
350 | .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__); | |
351 | proper_subset( $s2, $s1 ); | |
352 | } | |
353 | ||
354 | sub superset | |
355 | { | |
356 | my ($s1, $s2) = @_; | |
357 | croak("Tried to find superset of Set::Object & " | |
358 | .(ref($s2)||$s2)) unless UNIVERSAL::isa($s2, __PACKAGE__); | |
359 | subset( $s2, $s1 ); | |
360 | } | |
361 | ||
362 | # following code pasted from Set::Scalar; thanks Jarkko Hietaniemi | |
363 | ||
364 | use overload | |
365 | '""' => \&as_string, | |
366 | '+' => \&op_union, | |
367 | '*' => \&op_intersection, | |
368 | '%' => \&symmetric_difference, | |
369 | '-' => \&difference, | |
370 | '==' => \&equal, | |
371 | '!=' => \¬_equal, | |
372 | '<' => \&proper_subset, | |
373 | '>' => \&proper_superset, | |
374 | '<=' => \&subset, | |
375 | '>=' => \&superset | |
376 | ; | |
377 | ||
378 | # Autoload methods go after =cut, and are processed by the autosplit program. | |
379 | # This function is used to differentiate between an integer and a | |
380 | # string for use by the hash container types | |
381 | ||
382 | ||
383 | # This function is not from Scalar::Util; it is a DWIMy function to | |
384 | # decide whether the passed thingy could reasonably be considered | |
385 | # to be an array index, and if so returns the index | |
386 | sub ish_int { | |
387 | my $i; | |
388 | eval { $i = _ish_int($_[0]) }; | |
389 | ||
390 | if ($@) { | |
391 | if ($@ =~ /overload/i) { | |
392 | if (my $sub = UNIVERSAL::can($_[0], "(0+")) { | |
393 | return ish_int(&$sub($_[0])); | |
394 | } else { | |
395 | return undef; | |
396 | } | |
397 | } elsif ($@ =~ /tie/i) { | |
398 | my $x = $_[0]; | |
399 | return ish_int($x); | |
400 | } | |
401 | } else { | |
402 | return $i; | |
403 | } | |
404 | } | |
405 | ||
406 | # returns true if the value looks like a key, not an object or a | |
407 | # collection | |
408 | sub is_key { | |
409 | if (my $class = tied $_[0]) { | |
410 | if ($class =~ m/^Tangram::/) { # hack for Tangram RefOnDemands | |
411 | return undef; | |
412 | } else { | |
413 | my $x = $_[0]; | |
414 | return is_key($x); | |
415 | } | |
416 | } elsif (is_overloaded($_[0])) { | |
417 | # this is a bit of a hack - intrude into the overload internal | |
418 | # space | |
419 | if (my $sub = UNIVERSAL::can($_[0], "(0+")) { | |
420 | return is_key(&$sub($_[0])); | |
421 | } elsif ($sub = UNIVERSAL::can($_[0], '(""')) { | |
422 | return is_key(&$sub($_[0])); | |
423 | } elsif ($sub = UNIVERAL::can($_[0], '(nomethod')) { | |
424 | return is_key(&$sub($_[0])); | |
425 | } else { | |
426 | return undef; | |
427 | } | |
428 | } elsif (is_int($_[0]) || is_string($_[0]) || is_double($_[0])) { | |
429 | return 1; | |
430 | } else { | |
431 | return undef; | |
432 | } | |
433 | } | |
434 | ||
435 | # interface so that Storable may still work | |
436 | sub STORABLE_freeze { | |
437 | my $obj = shift; | |
438 | my $am_cloning = shift; | |
439 | return ("", $obj->members); | |
440 | } | |
441 | ||
442 | use Devel::Peek qw(Dump); | |
443 | ||
444 | sub STORABLE_thaw { | |
445 | #print Dump $_ foreach (@_); | |
446 | ||
447 | goto &_STORABLE_thaw; | |
448 | #print "Got here\n"; | |
449 | } | |
450 | 1; | |
451 | ||
452 | __END__ |