line
stmt
bran
cond
sub
pod
time
code
1
package List::Compare;
2
our $VERSION = '0.55';
3
34
34
2424437
use strict;
34
357
34
1348
4
local $^W = 1;
5
34
34
196
use Carp;
34
63
34
2624
6
34
44792
use List::Compare::Base::_Auxiliary qw(
7
_validate_2_seenhashes
8
_chart_engine_regular
9
34
34
18332
);
34
95
10
11
sub new {
12
212
212
1
83520
my $class = shift;
13
212
506
my (@args, $unsorted, $accelerated, $argument_error_status, $nextarg, @testargs);
14
212
100
100
1091
if (@_ == 1 and (ref($_[0]) eq 'HASH')) {
15
89
164
my $argref = shift;
16
die "Need to pass references to 2 or more seen-hashes or \n to provide a 'lists' key within the single hash being passed by reference"
17
89
100
134
unless exists ${$argref}{'lists'};
89
284
18
die "Need to define 'lists' key properly: $!"
19
88
297
unless ( ${$argref}{'lists'}
20
88
100
100
150
and (ref(${$argref}{'lists'}) eq 'ARRAY') );
87
337
21
86
156
@args = @{${$argref}{'lists'}};
86
126
86
234
22
86
100
141
$unsorted = ${$argref}{'unsorted'} ? 1 : '';
86
241
23
86
100
140
$accelerated = ${$argref}{'accelerated'} ? 1 : '';
86
227
24
} else {
25
123
328
@args = @_;
26
123
100
100
691
$unsorted = ($args[0] eq '-u' or $args[0] eq '--unsorted')
27
? shift(@args) : '';
28
123
100
100
592
$accelerated = shift(@args)
29
if ($args[0] eq '-a' or $args[0] eq '--accelerated');
30
}
31
209
385
$argument_error_status = 1;
32
209
679
@testargs = @args[1..$#args];
33
209
100
100
873
if (ref($args[0]) eq 'ARRAY' or ref($args[0]) eq 'HASH') {
34
195
578
while (defined ($nextarg = shift(@testargs))) {
35
339
100
1578
unless (ref($nextarg) eq ref($args[0])) {
36
16
34
$argument_error_status = 0;
37
16
36
last;
38
}
39
}
40
} else {
41
14
50
$argument_error_status = 0;
42
}
43
209
100
3543
croak "Must pass all array references or all hash references: $!"
44
unless $argument_error_status;
45
46
# Compose the name of the class
47
179
100
552
if (@args > 2) {
100
48
43
100
116
if ($accelerated) {
49
22
69
$class .= '::Multiple::Accelerated';
50
} else {
51
21
128
$class .= '::Multiple';
52
}
53
} elsif (@args == 2) {
54
129
100
278
if ($accelerated) {
55
61
165
$class .= '::Accelerated';
56
}
57
} else {
58
7
669
croak "Must pass at least 2 references to \&new: $!";
59
}
60
61
# do necessary calculations and store results in a hash
62
# take a reference to that hash
63
172
571
my $self = bless {}, $class;
64
172
100
702
my $dataref = $self->_init(($unsorted ? 1 : 0), @args);
65
66
# initialize the object from the prepared values (Damian, p. 98)
67
162
1094
%$self = %$dataref;
68
162
911
return $self;
69
}
70
71
sub _init {
72
68
68
114
my $self = shift;
73
68
145
my ($unsortflag, $refL, $refR) = @_;
74
68
123
my (%data, @left, @right, %seenL, %seenR);
75
68
100
149
if (ref($refL) eq 'HASH') {
76
27
123
my ($seenLref, $seenRref) = _validate_2_seenhashes($refL, $refR);
77
23
40
foreach my $key (keys %{$seenLref}) {
23
78
78
116
157
for (my $j=1; $j <= ${$seenLref}{$key}; $j++) {
255
496
79
139
212
push(@left, $key);
80
}
81
}
82
23
51
foreach my $key (keys %{$seenRref}) {
23
78
83
105
138
for (my $j=1; $j <= ${$seenRref}{$key}; $j++) {
228
425
84
123
199
push(@right, $key);
85
}
86
}
87
23
39
%seenL = %{$seenLref};
23
109
88
23
53
%seenR = %{$seenRref};
23
120
89
} else {
90
41
94
foreach (@$refL) { $seenL{$_}++ }
160
299
91
41
80
foreach (@$refR) { $seenR{$_}++ }
149
238
92
41
90
@left = @$refL;
93
41
83
@right = @$refR;
94
}
95
64
100
356
my @bag = $unsortflag ? (@left, @right) : sort(@left, @right);
96
64
123
my (%intersection, %union, %Lonly, %Ronly, %LorRonly);
97
64
99
my $LsubsetR_status = my $RsubsetL_status = 1;
98
64
91
my $LequivalentR_status = 0;
99
100
64
201
foreach (keys %seenL) {
101
252
376
$union{$_}++;
102
252
100
493
exists $seenR{$_} ? $intersection{$_}++ : $Lonly{$_}++;
103
}
104
105
64
237
foreach (keys %seenR) {
106
235
342
$union{$_}++;
107
235
100
485
$Ronly{$_}++ unless (exists $intersection{$_});
108
}
109
110
64
243
$LorRonly{$_}++ foreach ( (keys %Lonly), (keys %Ronly) );
111
112
64
100
160
$LequivalentR_status = 1 if ( (keys %LorRonly) == 0);
113
114
64
147
foreach (@left) {
115
180
100
340
if (! exists $seenR{$_}) {
116
39
60
$LsubsetR_status = 0;
117
39
81
last;
118
}
119
}
120
64
104
foreach (@right) {
121
233
100
428
if (! exists $seenL{$_}) {
122
32
55
$RsubsetL_status = 0;
123
32
53
last;
124
}
125
}
126
127
64
143
$data{'seenL'} = \%seenL;
128
64
115
$data{'seenR'} = \%seenR;
129
64
100
236
$data{'intersection'} = $unsortflag ? [ keys %intersection ]
130
: [ sort keys %intersection ];
131
64
100
298
$data{'union'} = $unsortflag ? [ keys %union ]
132
: [ sort keys %union ];
133
64
100
225
$data{'unique'} = $unsortflag ? [ keys %Lonly ]
134
: [ sort keys %Lonly ];
135
64
100
204
$data{'complement'} = $unsortflag ? [ keys %Ronly ]
136
: [ sort keys %Ronly ];
137
64
100
219
$data{'symmetric_difference'} = $unsortflag ? [ keys %LorRonly ]
138
: [ sort keys %LorRonly ];
139
64
166
$data{'LsubsetR_status'} = $LsubsetR_status;
140
64
117
$data{'RsubsetL_status'} = $RsubsetL_status;
141
64
104
$data{'LequivalentR_status'} = $LequivalentR_status;
142
64
100
162
$data{'LdisjointR_status'} = keys %intersection == 0 ? 1 : 0;
143
64
119
$data{'bag'} = \@bag;
144
64
283
return \%data;
145
}
146
147
sub get_intersection {
148
26
26
1
9408
return @{ get_intersection_ref(shift) };
26
87
149
}
150
151
sub get_intersection_ref {
152
52
52
0
5772
my $class = shift;
153
52
437
my %data = %$class;
154
52
449
return $data{'intersection'};
155
}
156
157
sub get_union {
158
8
8
1
6042
return @{ get_union_ref(shift) };
8
32
159
}
160
161
sub get_union_ref {
162
16
16
0
6987
my $class = shift;
163
16
118
my %data = %$class;
164
16
137
return $data{'union'};
165
}
166
167
sub get_shared {
168
8
8
1
16674
my $class = shift;
169
8
51
my $method = (caller(0))[3];
170
8
1576
carp "When comparing only 2 lists, $method defaults to \n ", 'get_intersection()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
171
8
857
get_intersection($class);
172
}
173
174
sub get_shared_ref {
175
8
8
0
21551
my $class = shift;
176
8
50
my $method = (caller(0))[3];
177
8
698
carp "When comparing only 2 lists, $method defaults to \n ", 'get_intersection_ref()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
178
8
560
get_intersection_ref($class);
179
}
180
181
sub get_unique {
182
24
24
1
25609
return @{ get_unique_ref(shift) };
24
78
183
}
184
185
sub get_unique_ref {
186
48
48
0
16815
my $class = shift;
187
48
292
my %data = %$class;
188
48
226
return $data{'unique'};
189
}
190
191
sub get_unique_all {
192
8
8
1
5627
my $class = shift;
193
8
65
my %data = %$class;
194
8
49
return [ $data{'unique'}, $data{'complement'} ];
195
}
196
197
{
198
34
34
319
no warnings 'once';
34
74
34
7048
199
*get_Lonly = \&get_unique;
200
*get_Aonly = \&get_unique;
201
*get_Lonly_ref = \&get_unique_ref;
202
*get_Aonly_ref = \&get_unique_ref;
203
}
204
205
sub get_complement {
206
24
24
1
18363
return @{ get_complement_ref(shift) };
24
99
207
}
208
209
sub get_complement_ref {
210
48
48
0
16725
my $class = shift;
211
48
298
my %data = %$class;
212
48
222
return $data{'complement'};
213
}
214
215
sub get_complement_all {
216
8
8
1
5586
my $class = shift;
217
8
69
my %data = %$class;
218
8
52
return [ $data{'complement'}, $data{'unique'} ];
219
}
220
221
{
222
34
34
276
no warnings 'once';
34
97
34
5314
223
*get_Ronly = \&get_complement;
224
*get_Bonly = \&get_complement;
225
*get_Ronly_ref = \&get_complement_ref;
226
*get_Bonly_ref = \&get_complement_ref;
227
}
228
229
sub get_symmetric_difference {
230
40
40
1
23830
return @{ get_symmetric_difference_ref(shift) };
40
107
231
}
232
233
sub get_symmetric_difference_ref {
234
80
80
0
22566
my $class = shift;
235
80
483
my %data = %$class;
236
80
408
return $data{'symmetric_difference'};
237
}
238
239
{
240
34
34
262
no warnings 'once';
34
76
34
9720
241
*get_symdiff = \&get_symmetric_difference;
242
*get_LorRonly = \&get_symmetric_difference;
243
*get_AorBonly = \&get_symmetric_difference;
244
*get_symdiff_ref = \&get_symmetric_difference_ref;
245
*get_LorRonly_ref = \&get_symmetric_difference_ref;
246
*get_AorBonly_ref = \&get_symmetric_difference_ref;
247
}
248
249
sub get_nonintersection {
250
8
8
1
11922
my $class = shift;
251
8
55
my $method = (caller(0))[3];
252
8
913
carp "When comparing only 2 lists, $method defaults to \n ", 'get_symmetric_difference()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
253
8
587
get_symmetric_difference($class);
254
}
255
256
sub get_nonintersection_ref {
257
8
8
1
20404
my $class = shift;
258
8
56
my $method = (caller(0))[3];
259
8
691
carp "When comparing only 2 lists, $method defaults to \n ", 'get_symmetric_difference_ref()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
260
8
506
get_symmetric_difference_ref($class);
261
}
262
263
sub is_LsubsetR {
264
48
48
1
15802
my $class = shift;
265
48
315
my %data = %$class;
266
48
188
return $data{'LsubsetR_status'};
267
}
268
269
34
34
333
{ no warnings 'once'; *is_AsubsetB = \&is_LsubsetR; }
34
99
34
4091
270
271
sub is_RsubsetL {
272
48
48
0
13109
my $class = shift;
273
48
283
my %data = %$class;
274
48
188
return $data{'RsubsetL_status'};
275
}
276
277
34
34
239
{ no warnings 'once'; *is_BsubsetA = \&is_RsubsetL; }
34
63
34
3012
278
279
sub is_LequivalentR {
280
48
48
1
15548
my $class = shift;
281
48
302
my %data = %$class;
282
48
200
return $data{'LequivalentR_status'};
283
}
284
285
34
34
229
{ no warnings 'once'; *is_LeqvlntR = \&is_LequivalentR; }
34
65
34
30805
286
287
sub is_LdisjointR {
288
34
34
1
7888
my $class = shift;
289
34
210
my %data = %$class;
290
34
135
return $data{'LdisjointR_status'};
291
}
292
293
sub print_subset_chart {
294
8
8
1
8428
my $class = shift;
295
8
68
my %data = %$class;
296
8
128
my @subset_array = ($data{'LsubsetR_status'}, $data{'RsubsetL_status'});
297
8
27
my $title = 'Subset';
298
8
137
_chart_engine_regular(\@subset_array, $title);
299
}
300
301
sub print_equivalence_chart {
302
8
8
1
16959
my $class = shift;
303
8
70
my %data = %$class;
304
my @equivalent_array = ($data{'LequivalentR_status'},
305
8
42
$data{'LequivalentR_status'});
306
8
17
my $title = 'Equivalence';
307
8
38
_chart_engine_regular(\@equivalent_array, $title);
308
}
309
310
sub is_member_which {
311
92
92
1
14669
return @{ is_member_which_ref(@_) };
92
169
312
}
313
314
sub is_member_which_ref {
315
185
185
1
8034
my $class = shift;
316
185
100
100
1421
croak "Method call requires exactly 1 argument (no references): $!"
317
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
318
176
686
my %data = %$class;
319
176
370
my $arg = shift;
320
176
242
my @found = ();
321
176
100
288
if (exists ${$data{'seenL'}}{$arg}) { push @found, 0; }
176
376
112
214
322
176
100
272
if (exists ${$data{'seenR'}}{$arg}) { push @found, 1; }
176
384
112
157
323
176
504
return \@found;
324
}
325
326
sub are_members_which {
327
13
13
1
6981
my $class = shift;
328
13
100
100
493
croak "Method call requires exactly 1 argument which must be an array reference\n holding the items to be tested: $!"
329
unless (@_ == 1 and ref($_[0]) eq 'ARRAY');
330
8
68
my %data = %$class;
331
8
24
my (@args, %found);
332
8
16
@args = @{$_[0]};
8
73
333
8
52
for (my $i=0; $i<=$#args; $i++) {
334
88
122
@{$found{$args[$i]}} = ();
88
184
335
88
100
129
if (exists ${$data{'seenL'}}{$args[$i]}) { push @{$found{$args[$i]}}, 0; }
88
188
56
74
56
114
336
88
100
116
if (exists ${$data{'seenR'}}{$args[$i]}) { push @{$found{$args[$i]}}, 1; }
88
208
56
75
56
121
337
}
338
8
50
return \%found;
339
}
340
341
sub is_member_any {
342
93
93
1
7153
my $class = shift;
343
93
100
100
790
croak "Method call requires exactly 1 argument (no references): $!"
344
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
345
88
354
my %data = %$class;
346
88
176
my $arg = shift;
347
( defined $data{'seenL'}{$arg} ) ||
348
88
100
100
394
( defined $data{'seenR'}{$arg} ) ? return 1 : return 0;
349
}
350
351
sub are_members_any {
352
13
13
1
6259
my $class = shift;
353
13
100
100
463
croak "Method call requires exactly 1 argument which must be an array reference\n holding the items to be tested: $!"
354
unless (@_ == 1 and ref($_[0]) eq 'ARRAY');
355
8
92
my %data = %$class;
356
8
26
my (@args, %present);
357
8
19
@args = @{$_[0]};
8
32
358
8
68
for (my $i=0; $i<=$#args; $i++) {
359
$present{$args[$i]} = ( defined $data{'seenL'}{$args[$i]} ) ||
360
88
100
100
378
( defined $data{'seenR'}{$args[$i]} ) ? 1 : 0;
361
}
362
8
63
return \%present;
363
}
364
365
sub get_bag {
366
8
8
1
14502
return @{ get_bag_ref(shift) };
8
38
367
}
368
369
sub get_bag_ref {
370
16
16
0
6448
my $class = shift;
371
16
112
my %data = %$class;
372
16
102
return $data{'bag'};
373
}
374
375
sub get_version {
376
8
8
1
4319
return $List::Compare::VERSION;
377
}
378
379
1;
380
381
################################################################################
382
383
package List::Compare::Accelerated;
384
34
34
282
use Carp;
34
97
34
2387
385
34
21493
use List::Compare::Base::_Auxiliary qw(
386
_argument_checker_0
387
_chart_engine_regular
388
_calc_seen
389
_equiv_engine
390
34
34
251
);
34
77
391
392
sub _init {
393
61
61
115
my $self = shift;
394
61
131
my ($unsortflag, $refL, $refR) = @_;
395
61
111
my %data = ();
396
61
189
($data{'L'}, $data{'R'}) = _argument_checker_0($refL, $refR);
397
57
100
159
$data{'unsort'} = $unsortflag ? 1 : 0;
398
57
146
return \%data;
399
}
400
401
sub get_intersection {
402
14
14
16896
return @{ get_intersection_ref(shift) };
14
56
403
}
404
405
sub get_intersection_ref {
406
28
28
6167
my $class = shift;
407
28
134
my %data = %$class;
408
$data{'unsort'}
409
? return _intersection_engine($data{'L'}, $data{'R'})
410
28
100
130
: return [ sort @{_intersection_engine($data{'L'}, $data{'R'})} ];
16
50
411
}
412
413
sub get_union {
414
8
8
5107
return @{ get_union_ref(shift) };
8
33
415
}
416
417
sub get_union_ref {
418
32
32
7151
my $class = shift;
419
32
145
my %data = %$class;
420
$data{'unsort'}
421
? return _union_engine($data{'L'}, $data{'R'})
422
32
100
138
: return [ sort @{_union_engine($data{'L'}, $data{'R'})} ];
16
48
423
}
424
425
sub get_shared {
426
8
8
16516
return @{ get_shared_ref(shift) };
8
46
427
}
428
429
sub get_shared_ref {
430
16
16
22723
my $class = shift;
431
16
102
my $method = (caller(0))[3];
432
16
145
$method =~ s/.*::(\w*)$/$1/;
433
16
2343
carp "When comparing only 2 lists, \&$method defaults to \n \&get_union_ref. Though the results returned are valid, \n please consider re-coding with that method: $!";
434
16
21995
&get_union_ref($class);
435
}
436
437
sub get_unique {
438
24
24
17687
return @{ get_unique_ref(shift) };
24
71
439
}
440
441
sub get_unique_ref {
442
64
64
17279
my $class = shift;
443
64
234
my %data = %$class;
444
$data{'unsort'}
445
? return _unique_engine($data{'L'}, $data{'R'})
446
64
100
230
: return [ sort @{_unique_engine($data{'L'}, $data{'R'})} ];
32
74
447
}
448
449
sub get_unique_all {
450
8
8
5639
my $class = shift;
451
8
34
return [ get_unique_ref($class), get_complement_ref($class) ];
452
}
453
454
{
455
34
34
307
no warnings 'once';
34
79
34
7445
456
*get_Lonly = \&get_unique;
457
*get_Aonly = \&get_unique;
458
*get_Lonly_ref = \&get_unique_ref;
459
*get_Aonly_ref = \&get_unique_ref;
460
}
461
462
sub get_complement {
463
24
24
19058
return @{ get_complement_ref(shift) };
24
63
464
}
465
466
sub get_complement_ref {
467
64
64
17114
my $class = shift;
468
64
230
my %data = %$class;
469
$data{'unsort'}
470
? return _complement_engine($data{'L'}, $data{'R'})
471
64
100
222
: return [ sort @{_complement_engine($data{'L'}, $data{'R'})} ];
32
80
472
}
473
474
sub get_complement_all {
475
8
8
5720
my $class = shift;
476
8
35
return [ get_complement_ref($class), get_unique_ref($class) ];
477
}
478
479
{
480
34
34
247
no warnings 'once';
34
75
34
6191
481
*get_Ronly = \&get_complement;
482
*get_Bonly = \&get_complement;
483
*get_Ronly_ref = \&get_complement_ref;
484
*get_Bonly_ref = \&get_complement_ref;
485
}
486
487
sub get_symmetric_difference {
488
32
32
25075
return @{ get_symmetric_difference_ref(shift) };
32
97
489
}
490
491
sub get_symmetric_difference_ref {
492
80
80
23331
my $class = shift;
493
80
364
my %data = %$class;
494
$data{'unsort'}
495
? return _symmetric_difference_engine($data{'L'}, $data{'R'})
496
80
100
288
: return [ sort @{_symmetric_difference_engine($data{'L'}, $data{'R'})} ];
40
99
497
}
498
499
{
500
34
34
308
no warnings 'once';
34
119
34
8098
501
*get_symdiff = \&get_symmetric_difference;
502
*get_LorRonly = \&get_symmetric_difference;
503
*get_AorBonly = \&get_symmetric_difference;
504
*get_symdiff_ref = \&get_symmetric_difference_ref;
505
*get_LorRonly_ref = \&get_symmetric_difference_ref;
506
*get_AorBonly_ref = \&get_symmetric_difference_ref;
507
}
508
509
sub get_nonintersection {
510
8
8
12447
return @{ get_nonintersection_ref(shift) };
8
41
511
}
512
513
sub get_nonintersection_ref {
514
16
16
21144
my $class = shift;
515
16
95
my $method = (caller(0))[3];
516
16
162
$method =~ s/.*::(\w*)$/$1/;
517
16
1680
carp "When comparing only 2 lists, \&$method defaults to \n \&get_symmetric_difference_ref. Though the results returned are valid, \n please consider re-coding with that method: $!";
518
16
1100
&get_symmetric_difference_ref($class);
519
}
520
521
sub is_LsubsetR {
522
38
38
15254
my $class = shift;
523
38
214
my %data = %$class;
524
38
138
return _is_LsubsetR_engine($data{'L'}, $data{'R'});
525
}
526
527
34
34
270
{ no warnings 'once'; *is_AsubsetB = \&is_LsubsetR; }
34
79
34
3364
528
529
sub is_RsubsetL {
530
38
38
11848
my $class = shift;
531
38
152
my %data = %$class;
532
38
134
return _is_RsubsetL_engine($data{'L'}, $data{'R'});
533
}
534
535
34
34
242
{ no warnings 'once'; *is_BsubsetA = \&is_RsubsetL; }
34
82
34
3280
536
537
sub is_LequivalentR {
538
48
48
14842
my $class = shift;
539
48
185
my %data = %$class;
540
48
152
return _is_LequivalentR_engine($data{'L'}, $data{'R'});
541
}
542
543
34
34
282
{ no warnings 'once'; *is_LeqvlntR = \&is_LequivalentR; }
34
75
34
78620
544
545
sub is_LdisjointR {
546
30
30
7388
my $class = shift;
547
30
139
my %data = %$class;
548
30
106
return _is_LdisjointR_engine($data{'L'}, $data{'R'});
549
}
550
551
sub print_subset_chart {
552
8
8
8792
my $class = shift;
553
8
54
my %data = %$class;
554
8
44
_print_subset_chart_engine($data{'L'}, $data{'R'});
555
}
556
557
sub print_equivalence_chart {
558
8
8
17117
my $class = shift;
559
8
55
my %data = %$class;
560
8
59
_print_equivalence_chart_engine($data{'L'}, $data{'R'});
561
}
562
563
sub is_member_which {
564
92
92
14562
return @{ is_member_which_ref(@_) };
92
166
565
}
566
567
sub is_member_which_ref {
568
185
185
7908
my $class = shift;
569
185
100
100
1442
croak "Method call requires exactly 1 argument (no references): $!"
570
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
571
176
425
my %data = %$class;
572
176
375
return _is_member_which_engine($data{'L'}, $data{'R'}, shift);
573
}
574
575
sub are_members_which {
576
13
13
6720
my $class = shift;
577
13
100
100
494
croak "Method call requires exactly 1 argument which must be an array reference\n holding the items to be tested: $!"
578
unless (@_ == 1 and ref($_[0]) eq 'ARRAY');
579
8
41
my %data = %$class;
580
8
19
my (@args);
581
8
18
@args = @{$_[0]};
8
32
582
8
41
return _are_members_which_engine($data{'L'}, $data{'R'}, \@args);
583
}
584
585
sub is_member_any {
586
93
93
7234
my $class = shift;
587
93
100
100
740
croak "Method call requires exactly 1 argument (no references): $!"
588
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
589
88
264
my %data = %$class;
590
88
202
return _is_member_any_engine($data{'L'}, $data{'R'}, shift);
591
}
592
593
sub are_members_any {
594
13
13
6161
my $class = shift;
595
13
100
100
474
croak "Method call requires exactly 1 argument which must be an array reference\n holding the items to be tested: $!"
596
unless (@_ == 1 and ref($_[0]) eq 'ARRAY');
597
8
45
my %data = %$class;
598
8
21
my (@args);
599
8
21
@args = @{$_[0]};
8
33
600
8
59
return _are_members_any_engine($data{'L'}, $data{'R'}, \@args);
601
}
602
603
sub get_bag {
604
8
8
14796
return @{ get_bag_ref(shift) };
8
44
605
}
606
607
sub get_bag_ref {
608
16
16
6686
my $class = shift;
609
16
108
my %data = %$class;
610
16
100
76
if (ref($data{'L'}) eq 'ARRAY') {
611
4
9
$data{'unsort'} ? return [ @{$data{'L'}}, @{$data{'R'}} ]
4
29
612
8
100
32
: return [ sort(@{$data{'L'}}, @{$data{'R'}}) ];
4
8
4
47
613
} else {
614
8
18
my (@left, @right);
615
8
15
foreach my $key (keys %{$data{'L'}}) {
8
32
616
56
109
for (my $j=1; $j <= ${$data{'L'}}{$key}; $j++) {
120
232
617
64
107
push(@left, $key);
618
}
619
}
620
8
56
foreach my $key (keys %{$data{'R'}}) {
8
30
621
56
130
for (my $j=1; $j <= ${$data{'R'}}{$key}; $j++) {
120
212
622
64
109
push(@right, $key);
623
}
624
}
625
8
100
141
$data{'unsort'} ? return [ @left, @right ]
626
: return [ sort(@left, @right) ];
627
}
628
}
629
630
sub get_version {
631
8
8
4272
return $List::Compare::VERSION;
632
}
633
634
sub _intersection_engine {
635
28
28
60
my ($l, $r) = @_;
636
28
88
my ($hrefL, $hrefR) = _calc_seen($l, $r);
637
28
63
my %intersection = ();
638
28
48
foreach (keys %{$hrefL}) {
28
99
639
160
100
199
$intersection{$_}++ if (exists ${$hrefR}{$_});
160
351
640
}
641
28
265
return [ keys %intersection ];
642
}
643
644
sub _union_engine {
645
32
32
72
my ($l, $r) = @_;
646
32
133
my ($hrefL, $hrefR) = _calc_seen($l, $r);
647
32
65
my %union = ();
648
32
50
$union{$_}++ foreach ( (keys %{$hrefL}), (keys %{$hrefR}) );
32
99
32
241
649
32
424
return [ keys %union ];
650
}
651
652
sub _unique_engine {
653
64
64
113
my ($l, $r) = @_;
654
64
187
my ($hrefL, $hrefR) = _calc_seen($l, $r);
655
64
154
my (%Lonly);
656
64
93
foreach (keys %{$hrefL}) {
64
200
657
448
100
536
$Lonly{$_}++ unless exists ${$hrefR}{$_};
448
894
658
}
659
64
439
return [ keys %Lonly ];
660
}
661
662
sub _complement_engine {
663
64
64
121
my ($l, $r) = @_;
664
64
191
my ($hrefL, $hrefR) = _calc_seen($l, $r);
665
64
122
my (%Ronly);
666
64
81
foreach (keys %{$hrefR}) {
64
211
667
448
100
556
$Ronly{$_}++ unless (exists ${$hrefL}{$_});
448
896
668
}
669
64
502
return [ keys %Ronly ];
670
}
671
672
sub _symmetric_difference_engine {
673
80
80
168
my ($l, $r) = @_;
674
80
234
my ($hrefL, $hrefR) = _calc_seen($l, $r);
675
80
142
my (%LorRonly);
676
80
106
foreach (keys %{$hrefL}) {
80
277
677
560
100
668
$LorRonly{$_}++ unless (exists ${$hrefR}{$_});
560
1177
678
}
679
80
146
foreach (keys %{$hrefR}) {
80
214
680
560
100
649
$LorRonly{$_}++ unless (exists ${$hrefL}{$_});
560
1042
681
}
682
80
631
return [ keys %LorRonly ];
683
}
684
685
sub _is_LsubsetR_engine {
686
38
38
99
my ($l, $r) = @_;
687
38
196
my ($hrefL, $hrefR) = _calc_seen($l, $r);
688
38
73
my $LsubsetR_status = 1;
689
38
79
foreach (keys %{$hrefL}) {
38
127
690
115
100
150
if (! exists ${$hrefR}{$_}) {
115
346
691
32
59
$LsubsetR_status = 0;
692
32
104
last;
693
}
694
}
695
38
171
return $LsubsetR_status;
696
}
697
698
sub _is_RsubsetL_engine {
699
38
38
127
my ($l, $r) = @_;
700
38
117
my ($hrefL, $hrefR) = _calc_seen($l, $r);
701
38
157
my $RsubsetL_status = 1;
702
38
62
foreach (keys %{$hrefR}) {
38
125
703
141
100
210
if (! exists ${$hrefL}{$_}) {
141
303
704
22
49
$RsubsetL_status = 0;
705
22
41
last;
706
}
707
}
708
38
165
return $RsubsetL_status;
709
}
710
711
sub _is_LequivalentR_engine {
712
48
48
98
my ($l, $r) = @_;
713
48
163
my ($hrefL, $hrefR) = _calc_seen($l, $r);
714
48
137
return _equiv_engine($hrefL, $hrefR);
715
}
716
717
sub _is_LdisjointR_engine {
718
30
30
74
my ($l, $r) = @_;
719
30
88
my ($hrefL, $hrefR) = _calc_seen($l, $r);
720
30
78
my %intersection = ();
721
30
53
foreach (keys %{$hrefL}) {
30
100
722
152
100
223
$intersection{$_}++ if (exists ${$hrefR}{$_});
152
389
723
}
724
30
100
176
keys %intersection == 0 ? 1 : 0;
725
}
726
727
sub _print_subset_chart_engine {
728
8
8
25
my ($l, $r) = @_;
729
8
34
my ($hrefL, $hrefR) = _calc_seen($l, $r);
730
8
27
my $LsubsetR_status = my $RsubsetL_status = 1;
731
8
19
foreach (keys %{$hrefL}) {
8
36
732
34
100
41
if (! exists ${$hrefR}{$_}) {
34
92
733
8
13
$LsubsetR_status = 0;
734
8
20
last;
735
}
736
}
737
8
22
foreach (keys %{$hrefR}) {
8
31
738
31
100
48
if (! exists ${$hrefL}{$_}) {
31
94
739
8
15
$RsubsetL_status = 0;
740
8
36
last;
741
}
742
}
743
8
29
my @subset_array = ($LsubsetR_status, $RsubsetL_status);
744
8
31
my $title = 'Subset';
745
8
46
_chart_engine_regular(\@subset_array, $title);
746
}
747
748
sub _print_equivalence_chart_engine {
749
8
8
25
my ($l, $r) = @_;
750
8
30
my ($hrefL, $hrefR) = _calc_seen($l, $r);
751
8
32
my $LequivalentR_status = _equiv_engine($hrefL, $hrefR);
752
8
28
my @equivalent_array = ($LequivalentR_status, $LequivalentR_status);
753
8
19
my $title = 'Equivalence';
754
8
32
_chart_engine_regular(\@equivalent_array, $title);
755
}
756
757
sub _is_member_which_engine {
758
176
176
303
my ($l, $r, $arg) = @_;
759
176
346
my ($hrefL, $hrefR) = _calc_seen($l, $r);
760
176
270
my @found = ();
761
176
100
215
if (exists ${$hrefL}{$arg}) { push @found, 0; }
176
338
112
196
762
176
100
220
if (exists ${$hrefR}{$arg}) { push @found, 1; }
176
312
112
150
763
176
546
return \@found;
764
}
765
766
sub _are_members_which_engine {
767
8
8
21
my ($l, $r, $arg) = @_;
768
8
33
my ($hrefL, $hrefR) = _calc_seen($l, $r);
769
8
23
my @args = @{$arg};
8
28
770
8
17
my (%found);
771
8
49
for (my $i=0; $i<=$#args; $i++) {
772
88
118
@{$found{$args[$i]}} = ();
88
173
773
88
100
119
if (exists ${$hrefL}{$args[$i]}) { push @{$found{$args[$i]}}, 0; }
88
188
56
74
56
103
774
88
100
119
if (exists ${$hrefR}{$args[$i]}) { push @{$found{$args[$i]}}, 1; }
88
193
56
95
56
129
775
}
776
8
46
return \%found;
777
}
778
779
sub _is_member_any_engine {
780
88
88
148
my ($l, $r, $arg) = @_;
781
88
186
my ($hrefL, $hrefR) = _calc_seen($l, $r);
782
( defined ${$hrefL}{$arg} ) ||
783
88
100
100
130
( defined ${$hrefR}{$arg} ) ? return 1 : return 0;
784
}
785
786
sub _are_members_any_engine {
787
8
8
25
my ($l, $r, $arg) = @_;
788
8
32
my ($hrefL, $hrefR) = _calc_seen($l, $r);
789
8
21
my @args = @{$arg};
8
41
790
8
21
my (%present);
791
8
60
for (my $i=0; $i<=$#args; $i++) {
792
$present{$args[$i]} = ( defined ${$hrefL}{$args[$i]} ) ||
793
88
100
100
131
( defined ${$hrefR}{$args[$i]} ) ? 1 : 0;
794
}
795
8
86
return \%present;
796
}
797
798
1;
799
800
################################################################################
801
802
package List::Compare::Multiple;
803
34
34
331
use Carp;
34
704
34
2420
804
34
61648
use List::Compare::Base::_Auxiliary qw(
805
_validate_seen_hash
806
_index_message1
807
_index_message2
808
_chart_engine_multiple
809
34
34
248
);
34
86
810
811
sub _init {
812
21
21
47
my $self = shift;
813
21
45
my $unsortflag = shift;
814
21
64
my @listrefs = @_;
815
21
40
my (@arrayrefs);
816
21
48
my $maxindex = $#listrefs;
817
21
100
75
if (ref($listrefs[0]) eq 'ARRAY') {
818
10
27
@arrayrefs = @listrefs;
819
} else {
820
11
61
_validate_seen_hash(@listrefs);
821
9
29
foreach my $href (@listrefs) {
822
49
62
my (@temp);
823
49
61
foreach my $key (keys %{$href}) {
49
112
824
255
328
for (my $j=1; $j <= ${$href}{$key}; $j++) {
555
965
825
300
496
push(@temp, $key);
826
}
827
}
828
49
106
push(@arrayrefs, \@temp);
829
}
830
}
831
832
19
51
my @bag = ();
833
19
82
foreach my $aref (@arrayrefs) {
834
101
399
push @bag, $_ foreach @$aref;
835
}
836
19
100
156
@bag = sort(@bag) unless $unsortflag;
837
838
19
48
my (@intersection, @union);
839
# will hold overall intersection/union
840
19
41
my @nonintersection = ();
841
# will hold all items except those found in each source list
842
# @intersection + @nonintersection = @union
843
19
41
my @shared = ();
844
# will hold all items found in at least 2 lists
845
19
38
my @symmetric_difference = ();
846
# will hold each item found in only one list regardless of list;
847
# equivalent to @union minus all items found in the lists
848
# underlying %xintersection
849
19
38
my (%intersection, %union);
850
# will be used to generate @intersection & @union
851
19
53
my %seen = ();
852
# will be hash of hashes, holding seen-hashes corresponding to
853
# the source lists
854
19
37
my %xintersection = ();
855
# will be hash of hashes, holding seen-hashes corresponding to
856
# the lists containing the intersections of each permutation of
857
# the source lists
858
19
41
my %shared = ();
859
# will be used to generate @shared
860
19
50
my @xunique = ();
861
# will be array of arrays, holding the items that are unique to
862
# the list whose index number is passed as an argument
863
19
48
my @xcomplement = ();
864
# will be array of arrays, holding the items that are found in
865
# any list other than the list whose index number is passed
866
# as an argument
867
19
56
my @xdisjoint = ();
868
# will be an array of arrays, holding an indicator as to whether
869
# any pair of lists are disjoint, i.e., have no intersection
870
871
# Calculate overall union and take steps needed to calculate overall
872
# intersection, unique, difference, etc.
873
19
93
for (my $i = 0; $i <= $#arrayrefs; $i++) {
874
101
154
my %seenthis = ();
875
101
136
foreach (@{$arrayrefs[$i]}) {
101
199
876
606
910
$seenthis{$_}++;
877
606
852
$union{$_}++;
878
}
879
101
230
$seen{$i} = \%seenthis;
880
101
287
for (my $j = $i+1; $j <=$#arrayrefs; $j++) {
881
223
324
my (%seenthat, %seenintersect);
882
223
442
my $ilabel = $i . '_' . $j;
883
223
279
$seenthat{$_}++ foreach (@{$arrayrefs[$j]});
223
757
884
223
487
foreach (keys %seenthat) {
885
938
100
1845
$seenintersect{$_}++ if (exists $seenthis{$_});
886
}
887
223
838
$xintersection{$ilabel} = \%seenintersect;
888
}
889
}
890
19
100
164
@union = $unsortflag ? keys %union : sort(keys %union);
891
892
# At this point we now have %seen, @union and %xintersection available
893
# for use in other calculations.
894
895
# Calculate overall intersection
896
# Inputs: %xintersection
897
19
100
my @xkeys = keys %xintersection;
898
19
52
%intersection = %{$xintersection{$xkeys[0]}};
19
115
899
19
104
for (my $m = 1; $m <= $#xkeys; $m++) {
900
204
277
my %compare = %{$xintersection{$xkeys[$m]}};
204
564
901
204
345
my %result = ();
902
204
383
foreach (keys %compare) {
903
532
100
959
$result{$_}++ if (exists $intersection{$_});
904
}
905
204
619
%intersection = %result;
906
}
907
19
100
85
@intersection = $unsortflag ? keys %intersection : sort(keys %intersection);
908
909
# Calculate nonintersection
910
# Inputs: @union %intersection
911
19
54
foreach (@union) {
912
207
100
433
push(@nonintersection, $_) unless (exists $intersection{$_});
913
}
914
915
# Calculate @xunique and @xdisjoint
916
# Inputs: @arrayrefs %seen %xintersection
917
19
83
for (my $i = 0; $i <= $#arrayrefs; $i++) {
918
101
181
my %seenthis = %{$seen{$i}};
101
489
919
101
224
my (@uniquethis, %deductions, %alldeductions);
920
# Get those elements of %xintersection which we'll need
921
# to subtract from %seenthis
922
101
284
foreach (keys %xintersection) {
923
1229
2657
my ($left, $right) = split /_/, $_;
924
1229
100
100
3506
if ($left == $i || $right == $i) {
925
446
680
$deductions{$_} = $xintersection{$_};
926
}
927
$xdisjoint[$left][$right] = $xdisjoint[$right][$left] =
928
1229
100
1501
! (keys %{$xintersection{$_}}) ? 1 : 0;
1229
2935
929
}
930
101
295
foreach my $ded (keys %deductions) {
931
446
553
foreach (keys %{$deductions{$ded}}) {
446
816
932
1196
1848
$alldeductions{$_}++;
933
}
934
}
935
101
231
foreach (keys %seenthis) {
936
516
100
931
push(@uniquethis, $_) unless ($alldeductions{$_});
937
}
938
101
218
$xunique[$i] = \@uniquethis;
939
101
384
$xdisjoint[$i][$i] = 0;
940
}
941
# @xunique is now available for use in further calculations,
942
# such as returning the items unique to a particular source list.
943
944
# Calculate @xcomplement
945
# Inputs: @arrayrefs %seen @union
946
19
86
for (my $i = 0; $i <= $#arrayrefs; $i++) {
947
101
143
my %seenthis = %{$seen{$i}};
101
316
948
101
173
my @complementthis = ();
949
101
220
foreach (@union) {
950
1133
100
2042
push(@complementthis, $_) unless (exists $seenthis{$_});
951
}
952
101
333
$xcomplement[$i] = \@complementthis;
953
}
954
# @xcomplement is now available for use in further calculations,
955
# such as returning the items in all lists different from those in a
956
# particular source list.
957
958
# Calculate @shared and @symmetric_difference
959
# Inputs: %xintersection @union
960
19
78
foreach my $q (keys %xintersection) {
961
223
285
$shared{$_}++ foreach (keys %{$xintersection{$q}});
223
619
962
}
963
19
100
145
@shared = $unsortflag ? keys %shared : sort(keys %shared);
964
19
66
foreach (@union) {
965
207
100
383
push(@symmetric_difference, $_) unless (exists $shared{$_});
966
}
967
# @shared and @symmetric_difference are now available.
968
969
19
48
my @xsubset = ();
970
19
107
foreach my $i (keys %seen) {
971
101
152
my %tempi = %{$seen{$i}};
101
298
972
101
274
foreach my $j (keys %seen) {
973
547
676
my %tempj = %{$seen{$j}};
547
1415
974
547
1110
$xsubset[$i][$j] = 1;
975
547
1055
foreach (keys %tempi) {
976
2808
100
5184
$xsubset[$i][$j] = 0 if (! $tempj{$_});
977
}
978
}
979
}
980
# @xsubset is now available
981
982
19
62
my @xequivalent = ();
983
19
82
for (my $f = 0; $f <= $#xsubset; $f++) {
984
101
196
for (my $g = 0; $g <= $#xsubset; $g++) {
985
547
776
$xequivalent[$f][$g] = 0;
986
547
100
100
1464
$xequivalent[$f][$g] = 1
987
if ($xsubset[$f][$g] and $xsubset[$g][$f]);
988
}
989
}
990
991
19
35
my (%data);
992
19
63
$data{'seen'} = \%seen;
993
19
46
$data{'maxindex'} = $maxindex;
994
19
46
$data{'intersection'} = \@intersection;
995
19
38
$data{'nonintersection'} = \@nonintersection;
996
19
44
$data{'union'} = \@union;
997
19
44
$data{'shared'} = \@shared;
998
19
40
$data{'symmetric_difference'} = \@symmetric_difference;
999
19
70
$data{'xunique'} = \@xunique;
1000
19
53
$data{'xcomplement'} = \@xcomplement;
1001
19
45
$data{'xsubset'} = \@xsubset;
1002
19
54
$data{'xequivalent'} = \@xequivalent;
1003
19
43
$data{'xdisjoint'} = \@xdisjoint;
1004
19
128
$data{'bag'} = \@bag;
1005
19
242
return \%data;
1006
}
1007
1008
sub get_intersection {
1009
8
8
6060
return @{ get_intersection_ref(shift) };
8
32
1010
}
1011
1012
sub get_intersection_ref {
1013
16
16
5801
my $class = shift;
1014
16
180
my %data = %$class;
1015
16
102
return $data{'intersection'};
1016
}
1017
1018
sub get_union {
1019
8
8
4892
return @{ get_union_ref(shift) };
8
34
1020
}
1021
1022
sub get_union_ref {
1023
16
16
6967
my $class = shift;
1024
16
219
my %data = %$class;
1025
16
103
return $data{'union'};
1026
}
1027
1028
sub get_shared {
1029
8
8
6447
return @{ get_shared_ref(shift) };
8
136
1030
}
1031
1032
sub get_shared_ref {
1033
16
16
6216
my $class = shift;
1034
16
115
my %data = %$class;
1035
16
86
return $data{'shared'};
1036
}
1037
1038
sub get_unique {
1039
36
36
12501
my $class = shift;
1040
36
285
my %data = %$class;
1041
36
100
143
my $index = defined $_[0] ? shift : 0;
1042
36
57
return @{ get_unique_ref($class, $index) };
36
84
1043
}
1044
1045
sub get_unique_ref {
1046
77
77
10608
my $class = shift;
1047
77
440
my %data = %$class;
1048
77
100
307
my $index = defined $_[0] ? shift : 0;
1049
77
290
_index_message1($index, \%data);
1050
72
129
return ${$data{'xunique'}}[$index];
72
486
1051
}
1052
1053
sub get_unique_all {
1054
8
8
14529
my $class = shift;
1055
8
79
my %data = %$class;
1056
8
39
return $data{'xunique'};
1057
}
1058
1059
sub get_Lonly {
1060
24
24
51101
my ($class, $index) = @_;
1061
24
145
my $method = (caller(0))[3];
1062
24
288
$method =~ s/.*::(\w*)$/$1/;
1063
24
2799
carp "When comparing 3 or more lists, \&$method or its alias defaults to \n ", 'get_unique()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
1064
24
2200
get_unique($class, $index);
1065
}
1066
1067
sub get_Lonly_ref {
1068
24
24
60610
my ($class, $index) = @_;
1069
24
144
my $method = (caller(0))[3];
1070
24
206
$method =~ s/.*::(\w*)$/$1/;
1071
24
2122
carp "When comparing 3 or more lists, \&$method or its alias defaults to \n ", 'get_unique_ref()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
1072
24
1530
get_unique_ref($class, $index);
1073
}
1074
1075
{
1076
34
34
307
no warnings 'once';
34
98
34
15364
1077
*get_Aonly = \&get_Lonly;
1078
*get_Aonly_ref = \&get_Lonly_ref;
1079
}
1080
1081
sub get_complement {
1082
44
44
26098
my $class = shift;
1083
44
379
my %data = %$class;
1084
44
100
170
my $index = defined $_[0] ? shift : 0;
1085
44
66
return @{ get_complement_ref($class, $index) };
44
114
1086
}
1087
1088
sub get_complement_ref {
1089
93
93
14786
my $class = shift;
1090
93
524
my %data = %$class;
1091
93
100
298
my $index = defined $_[0] ? shift : 0;
1092
93
336
_index_message1($index, \%data);
1093
88
160
return ${$data{'xcomplement'}}[$index];
88
624
1094
}
1095
1096
sub get_complement_all {
1097
8
8
12564
my $class = shift;
1098
8
73
my %data = %$class;
1099
8
40
return $data{'xcomplement'};
1100
}
1101
1102
sub get_Ronly {
1103
28
28
53770
my ($class, $index) = @_;
1104
28
173
my $method = (caller(0))[3];
1105
28
250
$method =~ s/.*::(\w*)$/$1/;
1106
28
2459
carp "When comparing 3 or more lists, \&$method or its alias defaults to \n ", 'get_complement()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
1107
28
1838
&get_complement($class, $index);
1108
}
1109
1110
sub get_Ronly_ref {
1111
28
28
71300
my ($class, $index) = @_;
1112
28
170
my $method = (caller(0))[3];
1113
28
247
$method =~ s/.*::(\w*)$/$1/;
1114
28
2467
carp "When comparing 3 or more lists, \&$method or its alias defaults to \n ", 'get_complement_ref()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
1115
28
1789
&get_complement_ref($class, $index);
1116
}
1117
1118
{
1119
34
34
318
no warnings 'once';
34
100
34
4780
1120
*get_Bonly = \&get_Ronly;
1121
*get_Bonly_ref = \&get_Ronly_ref;
1122
}
1123
1124
sub get_symmetric_difference {
1125
32
32
19937
return @{ get_symmetric_difference_ref(shift) };
32
102
1126
}
1127
1128
sub get_symmetric_difference_ref {
1129
64
64
11773
my $class = shift;
1130
64
445
my %data = %$class;
1131
64
389
return $data{'symmetric_difference'};
1132
}
1133
1134
{
1135
34
34
268
no warnings 'once';
34
102
34
8124
1136
*get_symdiff = \&get_symmetric_difference;
1137
*get_symdiff_ref = \&get_symmetric_difference_ref;
1138
}
1139
1140
sub get_LorRonly {
1141
16
16
29378
my $class = shift;
1142
16
103
my $method = (caller(0))[3];
1143
16
144
$method =~ s/.*::(\w*)$/$1/;
1144
16
1458
carp "When comparing 3 or more lists, \&$method or its alias defaults to \n ", 'get_symmetric_difference()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
1145
16
1031
get_symmetric_difference($class);
1146
}
1147
1148
sub get_LorRonly_ref {
1149
16
16
40665
my $class = shift;
1150
16
103
my $method = (caller(0))[3];
1151
16
149
$method =~ s/.*::(\w*)$/$1/;
1152
16
1429
carp "When comparing 3 or more lists, \&$method or its alias defaults to \n ", 'get_symmetric_difference_ref()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
1153
16
947
get_symmetric_difference_ref($class);
1154
}
1155
1156
{
1157
34
34
284
no warnings 'once';
34
84
34
7733
1158
*get_AorBonly = \&get_LorRonly;
1159
*get_AorBonly_ref = \&get_LorRonly_ref;
1160
}
1161
1162
sub get_nonintersection {
1163
8
8
13408
return @{ get_nonintersection_ref(shift) };
8
42
1164
}
1165
1166
sub get_nonintersection_ref {
1167
16
16
6341
my $class = shift;
1168
16
115
my %data = %$class;
1169
16
114
return $data{'nonintersection'};
1170
}
1171
1172
sub is_LsubsetR {
1173
57
57
24300
my $class = shift;
1174
57
395
my %data = %$class;
1175
57
254
my ($index_left, $index_right) = _index_message2(\%data, @_);
1176
48
93
my @subset_array = @{$data{'xsubset'}};
48
130
1177
48
104
my $subset_status = $subset_array[$index_left][$index_right];
1178
48
204
return $subset_status;
1179
}
1180
1181
34
34
282
{ no warnings 'once'; *is_AsubsetB = \&is_LsubsetR; }
34
80
34
6723
1182
1183
sub is_RsubsetL {
1184
16
16
26843
my $class = shift;
1185
16
124
my %data = %$class;
1186
16
109
my $method = (caller(0))[3];
1187
16
149
$method =~ s/.*::(\w*)$/$1/;
1188
16
1477
carp "When comparing 3 or more lists, \&$method or its alias is restricted to \n asking if the list which is the 2nd argument to the constructor \n is a subset of the list which is the 1st argument.\n For greater flexibility, please re-code with \&is_LsubsetR: $!";
1189
16
1093
@_ = (1,0);
1190
16
87
my ($index_left, $index_right) = _index_message2(\%data, @_);
1191
16
45
my @subset_array = @{$data{'xsubset'}};
16
56
1192
16
42
my $subset_status = $subset_array[$index_left][$index_right];
1193
16
133
return $subset_status;
1194
}
1195
1196
34
34
251
{ no warnings 'once'; *is_BsubsetA = \&is_RsubsetL; }
34
64
34
4438
1197
1198
sub is_LequivalentR {
1199
33
33
20899
my $class = shift;
1200
33
229
my %data = %$class;
1201
33
144
my ($index_left, $index_right) = _index_message2(\%data, @_);
1202
24
60
my @equivalent_array = @{$data{'xequivalent'}};
24
78
1203
24
53
my $equivalent_status = $equivalent_array[$index_left][$index_right];
1204
24
93
return $equivalent_status;
1205
}
1206
1207
34
34
258
{ no warnings 'once'; *is_LeqvlntR = \&is_LequivalentR; }
34
78
34
32921
1208
1209
sub is_LdisjointR {
1210
29
29
10121
my $class = shift;
1211
29
193
my %data = %$class;
1212
29
144
my ($index_left, $index_right) = _index_message2(\%data, @_);
1213
24
65
my @disjoint_array = @{$data{'xdisjoint'}};
24
76
1214
24
64
my $disjoint_status = $disjoint_array[$index_left][$index_right];
1215
24
138
return $disjoint_status;
1216
}
1217
1218
sub is_member_which {
1219
92
92
21525
return @{ is_member_which_ref(@_) };
92
176
1220
}
1221
1222
sub is_member_which_ref {
1223
185
185
23121
my $class = shift;
1224
185
100
100
1376
croak "Method call requires exactly 1 argument (no references): $!"
1225
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
1226
176
717
my %data = %$class;
1227
176
319
my %seen = %{$data{'seen'}};
176
468
1228
176
293
my ($arg, @found);
1229
176
251
$arg = shift;
1230
176
553
foreach (sort keys %seen) {
1231
880
100
1797
push @found, $_ if (exists $seen{$_}{$arg});
1232
}
1233
176
744
return \@found;
1234
}
1235
1236
sub are_members_which {
1237
13
13
22439
my $class = shift;
1238
13
100
100
494
croak "Method call requires exactly 1 argument which must be an array reference\n holding the items to be tested: $!"
1239
unless (@_ == 1 and ref($_[0]) eq 'ARRAY');
1240
8
78
my %data = %$class;
1241
8
30
my %seen = %{$data{'seen'}};
8
42
1242
8
24
my (@args, %found);
1243
8
19
@args = @{$_[0]};
8
39
1244
8
49
for (my $i=0; $i<=$#args; $i++) {
1245
88
125
my (@not_found);
1246
88
240
foreach (sort keys %seen) {
1247
440
881
exists ${$seen{$_}}{$args[$i]}
1248
440
100
533
? push @{$found{$args[$i]}}, $_
216
470
1249
: push @not_found, $_;
1250
}
1251
88
100
295
$found{$args[$i]} = [] if (@not_found == keys %seen);
1252
}
1253
8
45
return \%found;
1254
}
1255
1256
sub is_member_any {
1257
93
93
15992
my $class = shift;
1258
93
100
100
740
croak "Method call requires exactly 1 argument (no references): $!"
1259
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
1260
88
360
my %data = %$class;
1261
88
170
my %seen = %{$data{'seen'}};
88
261
1262
88
151
my ($arg, $k);
1263
88
128
$arg = shift;
1264
88
191
while ( $k = each %seen ) {
1265
190
100
662
return 1 if (defined $seen{$k}{$arg});
1266
}
1267
8
41
return 0;
1268
}
1269
1270
sub are_members_any {
1271
13
13
8044
my $class = shift;
1272
13
100
100
865
croak "Method call requires exactly 1 argument which must be an array reference\n holding the items to be tested: $!"
1273
unless (@_ == 1 and ref($_[0]) eq 'ARRAY');
1274
8
84
my %data = %$class;
1275
8
32
my %seen = %{$data{'seen'}};
8
69
1276
8
28
my (@args, %present);
1277
8
26
@args = @{$_[0]};
8
32
1278
8
60
for (my $i=0; $i<=$#args; $i++) {
1279
88
184
foreach (keys %seen) {
1280
440
100
777
unless (defined $present{$args[$i]}) {
1281
168
100
412
$present{$args[$i]} = 1 if $seen{$_}{$args[$i]};
1282
}
1283
}
1284
88
100
267
$present{$args[$i]} = 0 if (! defined $present{$args[$i]});
1285
}
1286
8
74
return \%present;
1287
}
1288
1289
sub print_subset_chart {
1290
8
8
10145
my $class = shift;
1291
8
87
my %data = %$class;
1292
8
33
my @subset_array = @{$data{'xsubset'}};
8
31
1293
8
22
my $title = 'Subset';
1294
8
49
_chart_engine_multiple(\@subset_array, $title);
1295
}
1296
1297
sub print_equivalence_chart {
1298
8
8
17219
my $class = shift;
1299
8
77
my %data = %$class;
1300
8
34
my @equivalent_array = @{$data{'xequivalent'}};
8
32
1301
8
22
my $title = 'Equivalence';
1302
8
42
_chart_engine_multiple(\@equivalent_array, $title);
1303
}
1304
1305
sub get_bag {
1306
8
8
6445
return @{ get_bag_ref(shift) };
8
40
1307
}
1308
1309
sub get_bag_ref {
1310
16
16
7171
my $class = shift;
1311
16
113
my %data = %$class;
1312
16
131
return $data{'bag'};
1313
}
1314
1315
sub get_version {
1316
8
8
5270
return $List::Compare::VERSION;
1317
}
1318
1319
1;
1320
1321
################################################################################
1322
1323
package List::Compare::Multiple::Accelerated;
1324
34
34
355
use Carp;
34
85
34
2554
1325
34
2664
use List::Compare::Base::_Auxiliary qw(
1326
_argument_checker_0
1327
_prepare_listrefs
1328
_subset_subengine
1329
_chart_engine_multiple
1330
_equivalent_subengine
1331
_index_message3
1332
_index_message4
1333
_subset_engine_multaccel
1334
34
34
245
);
34
111
1335
34
34
241
use List::Compare::Base::_Auxiliary qw(:calculate);
34
78
34
6529
1336
34
27122
use List::Compare::Base::_Engine qw(
1337
_unique_all_engine
1338
_complement_all_engine
1339
34
34
18806
);
34
100
1340
1341
sub _init {
1342
22
22
43
my $self = shift;
1343
22
38
my $unsortflag = shift;
1344
22
105
my @listrefs = _argument_checker_0(@_);
1345
22
51
my %data = ();
1346
22
81
for (my $i=0; $i<=$#listrefs; $i++) {
1347
118
302
$data{$i} = $listrefs[$i];
1348
}
1349
22
100
91
$data{'unsort'} = $unsortflag ? 1 : 0;
1350
22
66
return \%data;
1351
}
1352
1353
sub get_union {
1354
8
8
4511
return @{ get_union_ref(shift) };
8
32
1355
}
1356
1357
sub get_union_ref {
1358
16
16
6856
my $class = shift;
1359
16
82
my %data = %$class;
1360
16
42
my $unsortflag = $data{'unsort'};
1361
16
63
my $aref = _prepare_listrefs(\%data);
1362
1363
16
53
my $unionref = _calculate_union_only($aref);
1364
16
100
43
my @union = $unsortflag ? keys %{$unionref} : sort(keys %{$unionref});
8
33
8
57
1365
16
104
return \@union;
1366
}
1367
1368
sub get_intersection {
1369
8
8
5963
return @{ get_intersection_ref(shift) };
8
34
1370
}
1371
1372
sub get_intersection_ref {
1373
16
16
5468
my $class = shift;
1374
16
88
my %data = %$class;
1375
16
38
my $unsortflag = $data{'unsort'};
1376
16
79
my $aref = _prepare_listrefs(\%data);
1377
16
62
my $intermediate_ref = _calculate_intermediate($aref);
1378
my @intersection =
1379
16
100
47
$unsortflag ? keys %{$intermediate_ref} : sort(keys %{$intermediate_ref});
8
24
8
34
1380
16
102
return \@intersection;
1381
}
1382
1383
sub get_nonintersection {
1384
8
8
12585
return @{ get_nonintersection_ref(shift) };
8
38
1385
}
1386
1387
sub get_nonintersection_ref {
1388
16
16
5862
my $class = shift;
1389
16
84
my %data = %$class;
1390
16
43
my $unsortflag = $data{'unsort'};
1391
16
56
my $aref = _prepare_listrefs(\%data);
1392
1393
16
55
my $unionref = _calculate_union_only($aref);
1394
16
78
my $intermediate_ref = _calculate_intermediate($aref);
1395
16
32
my (@nonintersection);
1396
16
28
foreach my $el (keys %{$unionref}) {
16
63
1397
160
100
334
push(@nonintersection, $el) unless exists $intermediate_ref->{$el};
1398
}
1399
16
100
161
return [ $unsortflag ? @nonintersection : sort(@nonintersection) ];
1400
}
1401
1402
sub get_shared {
1403
8
8
6059
return @{ get_shared_ref(shift) };
8
48
1404
}
1405
1406
sub get_shared_ref {
1407
16
16
6055
my $class = shift;
1408
16
77
my %data = %$class;
1409
16
39
my $unsortflag = $data{'unsort'};
1410
16
59
my $aref = _prepare_listrefs(\%data);
1411
16
69
my $aseenref = _calculate_array_seen_only($aref);
1412
16
49
my $intermediate = _calculate_sharedref($aseenref);
1413
16
100
47
my @shared = $unsortflag ? keys %{$intermediate} : sort(keys %{$intermediate});
8
38
8
50
1414
16
130
return \@shared;
1415
}
1416
1417
sub get_symmetric_difference {
1418
32
32
19612
return @{ get_symmetric_difference_ref(shift) };
32
102
1419
}
1420
1421
sub get_symmetric_difference_ref {
1422
64
64
11272
my $class = shift;
1423
64
341
my %data = %$class;
1424
64
155
my $unsortflag = $data{'unsort'};
1425
64
250
my $aref = _prepare_listrefs(\%data);
1426
64
184
my $unionref = _calculate_union_only($aref);
1427
1428
64
160
my $aseenref = _calculate_array_seen_only($aref);
1429
64
159
my $sharedref = _calculate_sharedref($aseenref);
1430
1431
64
100
my (@symmetric_difference);
1432
64
180
foreach my $el (keys %{$unionref}) {
64
199
1433
640
100
1177
push(@symmetric_difference, $el) unless exists $sharedref->{$el};
1434
}
1435
64
100
751
return [ $unsortflag ? @symmetric_difference : sort(@symmetric_difference) ];
1436
}
1437
1438
{
1439
34
34
335
no warnings 'once';
34
95
34
9324
1440
*get_symdiff = \&get_symmetric_difference;
1441
*get_symdiff_ref = \&get_symmetric_difference_ref;
1442
}
1443
1444
sub get_LorRonly {
1445
16
16
29036
my $class = shift;
1446
16
116
my $method = (caller(0))[3];
1447
16
143
$method =~ s/.*::(\w*)$/$1/;
1448
16
1570
carp "When comparing 3 or more lists, \&$method or its alias defaults to \n ", 'get_symmetric_difference()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
1449
16
1037
get_symmetric_difference($class);
1450
}
1451
1452
sub get_LorRonly_ref {
1453
16
16
39181
my $class = shift;
1454
16
161
my $method = (caller(0))[3];
1455
16
155
$method =~ s/.*::(\w*)$/$1/;
1456
16
1383
carp "When comparing 3 or more lists, \&$method or its alias defaults to \n ", 'get_symmetric_difference_ref()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
1457
16
958
get_symmetric_difference_ref($class);
1458
}
1459
1460
{
1461
34
34
272
no warnings 'once';
34
73
34
15373
1462
*get_AorBonly = \&get_LorRonly;
1463
*get_AorBonly_ref = \&get_LorRonly_ref;
1464
}
1465
1466
sub get_unique {
1467
36
36
11760
my $class = shift;
1468
36
192
my %data = %$class;
1469
36
100
123
my $index = defined $_[0] ? shift : 0;
1470
36
79
return @{ get_unique_ref($class, $index) };
36
101
1471
}
1472
1473
sub get_unique_ref {
1474
77
77
10431
my $class = shift;
1475
77
517
my %data = %$class;
1476
77
100
253
my $index = defined $_[0] ? shift : 0;
1477
77
238
my $aref = _prepare_listrefs(\%data);
1478
77
121
_index_message3($index, $#{$aref});
77
322
1479
1480
72
244
my $unique_all_ref = _unique_all_engine($aref);
1481
72
110
return ${$unique_all_ref}[$index];
72
494
1482
}
1483
1484
sub get_unique_all {
1485
8
8
13958
my $class = shift;
1486
8
49
my %data = %$class;
1487
8
38
my $aref = _prepare_listrefs(\%data);
1488
8
38
return _unique_all_engine($aref);
1489
}
1490
1491
sub get_Lonly {
1492
24
24
48924
my ($class, $index) = @_;
1493
24
145
my $method = (caller(0))[3];
1494
24
202
$method =~ s/.*::(\w*)$/$1/;
1495
24
2564
carp "When comparing 3 or more lists, \&$method or its alias defaults to \n ", 'get_unique()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
1496
24
1823
get_unique($class, $index);
1497
}
1498
1499
sub get_Lonly_ref {
1500
24
24
57734
my ($class, $index) = @_;
1501
24
140
my $method = (caller(0))[3];
1502
24
212
$method =~ s/.*::(\w*)$/$1/;
1503
24
2098
carp "When comparing 3 or more lists, \&$method or its alias defaults to \n ", 'get_unique_ref()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
1504
24
1514
get_unique_ref($class, $index);
1505
}
1506
1507
{
1508
34
34
264
no warnings 'once';
34
71
34
18038
1509
*get_Aonly = \&get_Lonly;
1510
*get_Aonly_ref = \&get_Lonly_ref;
1511
}
1512
1513
sub get_complement {
1514
44
44
24980
my $class = shift;
1515
44
238
my %data = %$class;
1516
44
100
158
my $index = defined $_[0] ? shift : 0;
1517
44
81
return @{ get_complement_ref($class, $index) };
44
100
1518
}
1519
1520
sub get_complement_ref {
1521
93
93
14078
my $class = shift;
1522
93
374
my %data = %$class;
1523
93
100
267
my $index = defined $_[0] ? shift : 0;
1524
93
165
my $unsortflag = $data{'unsort'};
1525
93
291
my $aref = _prepare_listrefs(\%data);
1526
93
148
_index_message3($index, $#{$aref});
93
361
1527
1528
88
283
my $complement_all_ref = _complement_all_engine($aref, $unsortflag );
1529
88
137
return ${$complement_all_ref}[$index];
88
668
1530
}
1531
1532
sub get_complement_all {
1533
8
8
11749
my $class = shift;
1534
8
48
my %data = %$class;
1535
8
38
my $aref = _prepare_listrefs(\%data);
1536
8
45
return _complement_all_engine($aref);
1537
}
1538
1539
sub get_Ronly {
1540
28
28
52173
my ($class, $index) = @_;
1541
28
176
my $method = (caller(0))[3];
1542
28
243
$method =~ s/.*::(\w*)$/$1/;
1543
28
2599
carp "When comparing 3 or more lists, \&$method or its alias defaults to \n ", 'get_complement()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
1544
28
1919
&get_complement($class, $index);
1545
}
1546
1547
sub get_Ronly_ref {
1548
28
28
68531
my ($class, $index) = @_;
1549
28
176
my $method = (caller(0))[3];
1550
28
249
$method =~ s/.*::(\w*)$/$1/;
1551
28
2361
carp "When comparing 3 or more lists, \&$method or its alias defaults to \n ", 'get_complement_ref()', ". Though the results returned are valid, \n please consider re-coding with that method: $!";
1552
28
1731
&get_complement_ref($class, $index);
1553
}
1554
1555
{
1556
34
34
268
no warnings 'once';
34
82
34
3777
1557
*get_Bonly = \&get_Ronly;
1558
*get_Bonly_ref = \&get_Ronly_ref;
1559
}
1560
1561
sub is_LsubsetR {
1562
48
48
20154
my $class = shift;
1563
48
236
my %data = %$class;
1564
48
213
my $subset_status = _subset_engine_multaccel(\%data, @_);
1565
40
150
return $subset_status;
1566
}
1567
1568
34
34
247
{ no warnings 'once'; *is_AsubsetB = \&is_LsubsetR; }
34
70
34
5872
1569
1570
sub is_RsubsetL {
1571
16
16
27537
my $class = shift;
1572
16
89
my %data = %$class;
1573
1574
16
99
my $method = (caller(0))[3];
1575
16
135
$method =~ s/.*::(\w*)$/$1/;
1576
16
1551
carp "When comparing 3 or more lists, \&$method or its alias is restricted to \n asking if the list which is the 2nd argument to the constructor \n is a subset of the list which is the 1st argument.\n For greater flexibility, please re-code with \&is_LsubsetR: $!";
1577
16
1050
@_ = (1,0);
1578
1579
16
86
my $subset_status = _subset_engine_multaccel(\%data, @_);
1580
16
79
return $subset_status;
1581
}
1582
1583
34
34
257
{ no warnings 'once'; *is_BsubsetA = \&is_RsubsetL; }
34
72
34
4858
1584
1585
sub is_LequivalentR {
1586
33
33
19577
my $class = shift;
1587
33
165
my %data = %$class;
1588
33
123
my $aref = _prepare_listrefs(\%data);
1589
33
65
my ($index_left, $index_right) = _index_message4($#{$aref}, @_);
33
124
1590
1591
24
92
my $xequivalentref = _equivalent_subengine($aref);
1592
24
49
return ${$xequivalentref}[$index_left][$index_right];
24
126
1593
}
1594
1595
34
34
262
{ no warnings 'once'; *is_LeqvlntR = \&is_LequivalentR; }
34
88
34
51627
1596
1597
sub is_LdisjointR {
1598
29
29
8893
my $class = shift;
1599
29
154
my %data = %$class;
1600
29
112
my $aref = _prepare_listrefs(\%data);
1601
29
55
my ($index_left, $index_right) = _index_message4($#{$aref}, @_);
29
122
1602
24
105
my $aseenref = _calculate_array_seen_only(
1603
[ $aref->[$index_left], $aref->[$index_right] ]
1604
);
1605
24
56
my $disjoint_status = 1;
1606
24
39
OUTER: for my $k (keys %{$aseenref->[0]}) {
24
91
1607
55
100
130
if ($aseenref->[1]->{$k}) {
1608
16
30
$disjoint_status = 0;
1609
16
39
last OUTER;
1610
}
1611
}
1612
24
137
return $disjoint_status;
1613
}
1614
1615
sub is_member_which {
1616
92
92
21061
return @{ is_member_which_ref(@_) };
92
178
1617
}
1618
1619
sub is_member_which_ref {
1620
185
185
23207
my $class = shift;
1621
185
100
100
1659
croak "Method call requires exactly 1 argument (no references): $!"
1622
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
1623
176
232
my %data = %{$class};
176
565
1624
176
456
my $aref = _prepare_listrefs(\%data);
1625
176
365
my $seenref = _calculate_seen_only($aref);
1626
176
277
my ($arg, @found);
1627
176
252
$arg = shift;
1628
176
243
foreach (sort keys %{$seenref}) {
176
664
1629
880
100
1024
push @found, $_ if (exists ${$seenref}{$_}{$arg});
880
1830
1630
}
1631
176
1026
return \@found;
1632
}
1633
1634
sub are_members_which {
1635
13
13
22219
my $class = shift;
1636
13
100
100
536
croak "Method call requires exactly 1 argument which must be an array reference\n holding the items to be tested: $!"
1637
unless (@_ == 1 and ref($_[0]) eq 'ARRAY');
1638
8
22
my %data = %{$class};
8
50
1639
8
46
my $aref = _prepare_listrefs(\%data);
1640
8
35
my $seenref = _calculate_seen_only($aref);
1641
8
31
my (@args, %found);
1642
8
25
@args = @{$_[0]};
8
50
1643
8
50
for (my $i=0; $i<=$#args; $i++) {
1644
88
118
my (@not_found);
1645
88
146
foreach (sort keys %{$seenref}) {
88
276
1646
440
517
exists ${${$seenref}{$_}}{$args[$i]}
440
926
1647
440
100
547
? push @{$found{$args[$i]}}, $_
216
463
1648
: push @not_found, $_;
1649
}
1650
88
100
158
$found{$args[$i]} = [] if (@not_found == keys %{$seenref});
88
283
1651
}
1652
8
72
return \%found;
1653
}
1654
1655
sub is_member_any {
1656
93
93
15675
my $class = shift;
1657
93
100
100
790
croak "Method call requires exactly 1 argument (no references): $!"
1658
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
1659
88
288
my %data = %$class;
1660
88
222
my $aref = _prepare_listrefs(\%data);
1661
88
197
my $seenref = _calculate_seen_only($aref);
1662
88
133
my ($arg, $k);
1663
88
145
$arg = shift;
1664
88
118
while ( $k = each %{$seenref} ) {
195
446
1665
187
100
232
return 1 if (defined ${$seenref}{$k}{$arg});
187
696
1666
}
1667
8
52
return 0;
1668
}
1669
1670
sub are_members_any {
1671
13
13
7232
my $class = shift;
1672
13
100
100
475
croak "Method call requires exactly 1 argument which must be an array reference\n holding the items to be tested: $!"
1673
unless (@_ == 1 and ref($_[0]) eq 'ARRAY');
1674
8
55
my %data = %$class;
1675
8
42
my $aref = _prepare_listrefs(\%data);
1676
8
33
my $seenref = _calculate_seen_only($aref);
1677
8
31
my (@args, %present);
1678
8
15
@args = @{$_[0]};
8
33
1679
8
70
for (my $i=0; $i<=$#args; $i++) {
1680
88
116
foreach (keys %{$seenref}) {
88
193
1681
440
100
753
unless (defined $present{$args[$i]}) {
1682
179
100
224
$present{$args[$i]} = 1 if ${$seenref}{$_}{$args[$i]};
179
428
1683
}
1684
}
1685
88
100
258
$present{$args[$i]} = 0 if (! defined $present{$args[$i]});
1686
}
1687
8
85
return \%present;
1688
}
1689
1690
sub print_subset_chart {
1691
8
8
9525
my $class = shift;
1692
8
51
my %data = %$class;
1693
8
45
my $aref = _prepare_listrefs(\%data);
1694
8
47
my $xsubsetref = _subset_subengine($aref);
1695
8
24
my $title = 'Subset';
1696
8
44
_chart_engine_multiple($xsubsetref, $title);
1697
}
1698
1699
sub print_equivalence_chart {
1700
8
8
16621
my $class = shift;
1701
8
51
my %data = %$class;
1702
8
43
my $aref = _prepare_listrefs(\%data);
1703
8
35
my $xequivalentref = _equivalent_subengine($aref);
1704
8
22
my $title = 'Equivalence';
1705
8
31
_chart_engine_multiple($xequivalentref, $title);
1706
}
1707
1708
sub get_bag {
1709
8
8
5923
return @{ get_bag_ref(shift) };
8
56
1710
}
1711
1712
sub get_bag_ref {
1713
16
16
6709
my $class = shift;
1714
16
77
my %data = %$class;
1715
16
43
my $unsortflag = $data{'unsort'};
1716
16
75
my $aref = _prepare_listrefs(\%data);
1717
16
34
my (@bag);
1718
16
38
my @listrefs = @{$aref};
16
41
1719
16
100
63
if (ref($listrefs[0]) eq 'ARRAY') {
1720
8
18
foreach my $lref (@listrefs) {
1721
40
65
foreach my $el (@{$lref}) {
40
61
1722
256
380
push(@bag, $el);
1723
}
1724
}
1725
} else {
1726
8
19
foreach my $lref (@listrefs) {
1727
40
47
foreach my $key (keys %{$lref}) {
40
127
1728
216
262
for (my $j=1; $j <= ${$lref}{$key}; $j++) {
472
842
1729
256
407
push(@bag, $key);
1730
}
1731
}
1732
}
1733
}
1734
16
100
111
@bag = sort(@bag) unless $unsortflag;
1735
16
141
return \@bag;
1736
}
1737
1738
sub get_version {
1739
8
8
4949
return $List::Compare::VERSION;
1740
}
1741
1742
1;
1743
1744
1745
#################### DOCUMENTATION ####################
1746
1747
=encoding utf-8
1748
1749
=head1 NAME
1750
1751
List::Compare - Compare elements of two or more lists
1752
1753
=head1 VERSION
1754
1755
This document refers to version 0.55 of List::Compare. This version was
1756
released August 16 2020.
1757
1758
=head1 SYNOPSIS
1759
1760
The bare essentials:
1761
1762
@Llist = qw(abel abel baker camera delta edward fargo golfer);
1763
@Rlist = qw(baker camera delta delta edward fargo golfer hilton);
1764
1765
$lc = List::Compare->new(\@Llist, \@Rlist);
1766
1767
@intersection = $lc->get_intersection;
1768
@union = $lc->get_union;
1769
1770
... and so forth.
1771
1772
=head1 DISCUSSION: Modes and Methods
1773
1774
=head2 Regular Case: Compare Two Lists
1775
1776
=over 4
1777
1778
=item * Constructor: C
1779
1780
Create a List::Compare object. Put the two lists into arrays (named or
1781
anonymous) and pass references to the arrays to the constructor.
1782
1783
@Llist = qw(abel abel baker camera delta edward fargo golfer);
1784
@Rlist = qw(baker camera delta delta edward fargo golfer hilton);
1785
1786
$lc = List::Compare->new(\@Llist, \@Rlist);
1787
1788
By default, List::Compare's methods return lists which are sorted using
1789
Perl's default C mode: ASCII-betical sorting. Should you
1790
not need to have these lists sorted, you may achieve a speed boost
1791
by constructing the List::Compare object with the unsorted option:
1792
1793
$lc = List::Compare->new('-u', \@Llist, \@Rlist);
1794
1795
or
1796
1797
$lc = List::Compare->new('--unsorted', \@Llist, \@Rlist);
1798
1799
=item * Alternative Constructor
1800
1801
If you prefer a more explicit delineation of the types of arguments passed
1802
to a function, you may use this 'single hashref' kind of constructor to build a
1803
List::Compare object:
1804
1805
$lc = List::Compare->new( { lists => [\@Llist, \@Rlist] } );
1806
1807
or
1808
1809
$lc = List::Compare->new( {
1810
lists => [\@Llist, \@Rlist],
1811
unsorted => 1,
1812
} );
1813
1814
=item * C
1815
1816
Get those items which appear at least once in both lists (their intersection).
1817
1818
@intersection = $lc->get_intersection;
1819
1820
=item * C
1821
1822
Get those items which appear at least once in either list (their union).
1823
1824
@union = $lc->get_union;
1825
1826
=item * C
1827
1828
Get those items which appear (at least once) only in the first list.
1829
1830
@Lonly = $lc->get_unique;
1831
@Lonly = $lc->get_Lonly; # alias
1832
1833
=item * C
1834
1835
Get those items which appear (at least once) only in the second list.
1836
1837
@Ronly = $lc->get_complement;
1838
@Ronly = $lc->get_Ronly; # alias
1839
1840
=item * C
1841
1842
Get those items which appear at least once in either the first or the second
1843
list, but not both.
1844
1845
@LorRonly = $lc->get_symmetric_difference;
1846
@LorRonly = $lc->get_symdiff; # alias
1847
@LorRonly = $lc->get_LorRonly; # alias
1848
1849
=item * C
1850
1851
Make a bag of all those items in both lists. The bag differs from the
1852
union of the two lists in that it holds as many copies of individual
1853
elements as appear in the original lists.
1854
1855
@bag = $lc->get_bag;
1856
1857
=item * Return references rather than lists
1858
1859
An alternative approach to the above methods: If you do not immediately
1860
require an array as the return value of the method call, but simply need
1861
a I to an (anonymous) array, use one of the following
1862
parallel methods:
1863
1864
$intersection_ref = $lc->get_intersection_ref;
1865
$union_ref = $lc->get_union_ref;
1866
$Lonly_ref = $lc->get_unique_ref;
1867
$Lonly_ref = $lc->get_Lonly_ref; # alias
1868
$Ronly_ref = $lc->get_complement_ref;
1869
$Ronly_ref = $lc->get_Ronly_ref; # alias
1870
$LorRonly_ref = $lc->get_symmetric_difference_ref;
1871
$LorRonly_ref = $lc->get_symdiff_ref; # alias
1872
$LorRonly_ref = $lc->get_LorRonly_ref; # alias
1873
$bag_ref = $lc->get_bag_ref;
1874
1875
=item * C
1876
1877
Return a true value if the first argument passed to the constructor
1878
('L' for 'left') is a subset of the second argument passed to the
1879
constructor ('R' for 'right').
1880
1881
$LR = $lc->is_LsubsetR;
1882
1883
Return a true value if R is a subset of L.
1884
1885
$RL = $lc->is_RsubsetL;
1886
1887
=item * C
1888
1889
Return a true value if the two lists passed to the constructor are
1890
equivalent, I if every element in the left-hand list ('L') appears
1891
at least once in the right-hand list ('R') and I.
1892
1893
$eqv = $lc->is_LequivalentR;
1894
$eqv = $lc->is_LeqvlntR; # alias
1895
1896
=item * C
1897
1898
Return a true value if the two lists passed to the constructor are
1899
disjoint, I if the two lists have zero elements in common (or, what
1900
is the same thing, if their intersection is an empty set).
1901
1902
$disj = $lc->is_LdisjointR;
1903
1904
=item * C
1905
1906
Pretty-print a chart showing whether one list is a subset of the other.
1907
1908
$lc->print_subset_chart;
1909
1910
=item * C
1911
1912
Pretty-print a chart showing whether the two lists are equivalent (same
1913
elements found at least once in both).
1914
1915
$lc->print_equivalence_chart;
1916
1917
=item * C
1918
1919
Determine in I (if any) of the lists passed to the constructor a given
1920
string can be found. In list context, return a list of those indices in the
1921
constructor's argument list corresponding to lists holding the string being
1922
tested.
1923
1924
@memb_arr = $lc->is_member_which('abel');
1925
1926
In the example above, C<@memb_arr> will be:
1927
1928
( 0 )
1929
1930
because C<'abel'> is found only in C<@Al> which holds position C<0> in the
1931
list of arguments passed to C.
1932
1933
In scalar context, the return value is the number of lists passed to the
1934
constructor in which a given string is found.
1935
1936
As with other List::Compare methods which return a list, you may wish the
1937
above method returned a (scalar) reference to an array holding the list:
1938
1939
$memb_arr_ref = $lc->is_member_which_ref('baker');
1940
1941
In the example above, C<$memb_arr_ref> will be:
1942
1943
[ 0, 1 ]
1944
1945
because C<'baker'> is found in C<@Llist> and C<@Rlist>, which hold positions
1946
C<0> and C<1>, respectively, in the list of arguments passed to C.
1947
1948
B methods C and C test
1949
only one string at a time and hence take only one argument. To test more
1950
than one string at a time see the next method, C.
1951
1952
=item * C
1953
1954
Determine in I (if any) of the lists passed to the constructor one or
1955
more given strings can be found. The strings to be tested are placed in an
1956
array (named or anonymous); a reference to that array is passed to the method.
1957
1958
$memb_hash_ref =
1959
$lc->are_members_which([ qw| abel baker fargo hilton zebra | ]);
1960
1961
I In versions of List::Compare prior to 0.25 (April 2004), the
1962
strings to be tested could be passed as a flat list. This is no longer
1963
possible; the argument must now be a reference to an array.
1964
1965
The return value is a reference to a hash of arrays. The
1966
key for each element in this hash is the string being tested. Each element's
1967
value is a reference to an anonymous array whose elements are those indices in
1968
the constructor's argument list corresponding to lists holding the strings
1969
being tested. In the examples above, C<$memb_hash_ref> will be:
1970
1971
{
1972
abel => [ 0 ],
1973
baker => [ 0, 1 ],
1974
fargo => [ 0, 1 ],
1975
hilton => [ 1 ],
1976
zebra => [ ],
1977
};
1978
1979
B C can take more than one argument;
1980
C and C each take only one argument.
1981
Unlike those two methods, C returns a hash reference.
1982
1983
=item * C
1984
1985
Determine whether a given string can be found in I of the lists passed as
1986
arguments to the constructor. Return 1 if a specified string can be found in
1987
any of the lists and 0 if not.
1988
1989
$found = $lc->is_member_any('abel');
1990
1991
In the example above, C<$found> will be C<1> because C<'abel'> is found in one
1992
or more of the lists passed as arguments to C.
1993
1994
=item * C
1995
1996
Determine whether a specified string or strings can be found in I of the
1997
lists passed as arguments to the constructor. The strings to be tested are
1998
placed in an array (named or anonymous); a reference to that array is passed to
1999
C.
2000
2001
$memb_hash_ref = $lc->are_members_any([ qw| abel baker fargo hilton zebra | ]);
2002
2003
I In versions of List::Compare prior to 0.25 (April 2004), the
2004
strings to be tested could be passed as a flat list. This is no longer
2005
possible; the argument must now be a reference to an array.
2006
2007
The return value is a reference to a hash where an element's key is the
2008
string being tested and the element's value is 1 if the string can be
2009
found in I of the lists and 0 if not. In the examples above,
2010
C<$memb_hash_ref> will be:
2011
2012
{
2013
abel => 1,
2014
baker => 1,
2015
fargo => 1,
2016
hilton => 1,
2017
zebra => 0,
2018
};
2019
2020
C's value is C<0> because C is not found in either of the lists
2021
passed as arguments to C.
2022
2023
=item * C
2024
2025
Return current List::Compare version number.
2026
2027
$vers = $lc->get_version;
2028
2029
=back
2030
2031
=head2 Accelerated Case: When User Only Wants a Single Comparison
2032
2033
=over 4
2034
2035
=item * Constructor C
2036
2037
If you are certain that you will only want the results of a I
2038
comparison, computation may be accelerated by passing C<'-a'> or
2039
C<'--accelerated> as the first argument to the constructor.
2040
2041
@Llist = qw(abel abel baker camera delta edward fargo golfer);
2042
@Rlist = qw(baker camera delta delta edward fargo golfer hilton);
2043
2044
$lca = List::Compare->new('-a', \@Llist, \@Rlist);
2045
2046
or
2047
2048
$lca = List::Compare->new('--accelerated', \@Llist, \@Rlist);
2049
2050
As with List::Compare's Regular case, should you not need to have
2051
a sorted list returned by an accelerated List::Compare method, you may
2052
achieve a speed boost by constructing the accelerated List::Compare object
2053
with the unsorted option:
2054
2055
$lca = List::Compare->new('-u', '-a', \@Llist, \@Rlist);
2056
2057
or
2058
2059
$lca = List::Compare->new('--unsorted', '--accelerated', \@Llist, \@Rlist);
2060
2061
=item * Alternative Constructor
2062
2063
You may use the 'single hashref' constructor format to build a List::Compare
2064
object calling for the Accelerated mode:
2065
2066
$lca = List::Compare->new( {
2067
lists => [\@Llist, \@Rlist],
2068
accelerated => 1,
2069
} );
2070
2071
or
2072
2073
$lca = List::Compare->new( {
2074
lists => [\@Llist, \@Rlist],
2075
accelerated => 1,
2076
unsorted => 1,
2077
} );
2078
2079
=item * Methods
2080
2081
All the comparison methods available in the Regular case are available to
2082
you in the Accelerated case as well.
2083
2084
@intersection = $lca->get_intersection;
2085
@union = $lca->get_union;
2086
@Lonly = $lca->get_unique;
2087
@Ronly = $lca->get_complement;
2088
@LorRonly = $lca->get_symmetric_difference;
2089
@bag = $lca->get_bag;
2090
$intersection_ref = $lca->get_intersection_ref;
2091
$union_ref = $lca->get_union_ref;
2092
$Lonly_ref = $lca->get_unique_ref;
2093
$Ronly_ref = $lca->get_complement_ref;
2094
$LorRonly_ref = $lca->get_symmetric_difference_ref;
2095
$bag_ref = $lca->get_bag_ref;
2096
$LR = $lca->is_LsubsetR;
2097
$RL = $lca->is_RsubsetL;
2098
$eqv = $lca->is_LequivalentR;
2099
$disj = $lca->is_LdisjointR;
2100
$lca->print_subset_chart;
2101
$lca->print_equivalence_chart;
2102
@memb_arr = $lca->is_member_which('abel');
2103
$memb_arr_ref = $lca->is_member_which_ref('baker');
2104
$memb_hash_ref = $lca->are_members_which(
2105
[ qw| abel baker fargo hilton zebra | ]);
2106
$found = $lca->is_member_any('abel');
2107
$memb_hash_ref = $lca->are_members_any(
2108
[ qw| abel baker fargo hilton zebra | ]);
2109
$vers = $lca->get_version;
2110
2111
All the aliases for methods available in the Regular case are available to
2112
you in the Accelerated case as well.
2113
2114
=back
2115
2116
=head2 Multiple Case: Compare Three or More Lists
2117
2118
=over 4
2119
2120
=item * Constructor C
2121
2122
Create a List::Compare object. Put each list into an array and pass
2123
references to the arrays to the constructor.
2124
2125
@Al = qw(abel abel baker camera delta edward fargo golfer);
2126
@Bob = qw(baker camera delta delta edward fargo golfer hilton);
2127
@Carmen = qw(fargo golfer hilton icon icon jerky kappa);
2128
@Don = qw(fargo icon jerky);
2129
@Ed = qw(fargo icon icon jerky);
2130
2131
$lcm = List::Compare->new(\@Al, \@Bob, \@Carmen, \@Don, \@Ed);
2132
2133
As with List::Compare's Regular case, should you not need to have
2134
a sorted list returned by a List::Compare method, you may achieve a
2135
speed boost by constructing the object with the unsorted option:
2136
2137
$lcm = List::Compare->new('-u', \@Al, \@Bob, \@Carmen, \@Don, \@Ed);
2138
2139
or
2140
2141
$lcm = List::Compare->new('--unsorted', \@Al, \@Bob, \@Carmen, \@Don, \@Ed);
2142
2143
=item * Alternative Constructor
2144
2145
You may use the 'single hashref' constructor format to build a List::Compare
2146
object to process three or more lists at once:
2147
2148
$lcm = List::Compare->new( {
2149
lists => [\@Al, \@Bob, \@Carmen, \@Don, \@Ed],
2150
} );
2151
2152
or
2153
2154
$lcm = List::Compare->new( {
2155
lists => [\@Al, \@Bob, \@Carmen, \@Don, \@Ed],
2156
unsorted => 1,
2157
} );
2158
2159
=item * Multiple Mode Methods Analogous to Regular and Accelerated Mode Methods
2160
2161
Each List::Compare method available in the Regular and Accelerated cases
2162
has an analogue in the Multiple case. However, the results produced
2163
usually require more careful specification.
2164
2165
B Certain of the following methods available in List::Compare's
2166
Multiple mode take optional numerical arguments where those numbers
2167
represent the index position of a particular list in the list of arguments
2168
passed to the constructor. To specify this index position correctly,
2169
2170
=over 4
2171
2172
=item *
2173
2174
start the count at C<0> (as is customary with Perl array indices); and
2175
2176
=item *
2177
2178
do I count any unsorted option (C<'-u'> or C<'--unsorted'>) preceding
2179
the array references in the constructor's own argument list.
2180
2181
=back
2182
2183
Example:
2184
2185
$lcmex = List::Compare->new('--unsorted', \@alpha, \@beta, \@gamma);
2186
2187
For the purpose of supplying a numerical argument to a method which
2188
optionally takes such an argument, C<'--unsorted'> is skipped, C<@alpha>
2189
is C<0>, C<@beta> is C<1>, and so forth.
2190
2191
=over 4
2192
2193
=item * C
2194
2195
Get those items found in I of the lists passed to the constructor
2196
(their intersection):
2197
2198
@intersection = $lcm->get_intersection;
2199
2200
=item * C
2201
2202
Get those items found in I of the lists passed to the constructor
2203
(their union):
2204
2205
@union = $lcm->get_union;
2206
2207
=item * C
2208
2209
To get those items which appear only in I provide
2210
C with that list's index position in the list of arguments
2211
passed to the constructor (not counting any C<'-u'> or C<'--unsorted'>
2212
option).
2213
2214
Example: C<@Carmen> has index position C<2> in the constructor's C<@_>.
2215
To get elements unique to C<@Carmen>:
2216
2217
@Lonly = $lcm->get_unique(2);
2218
2219
If no index position is passed to C it will default to 0
2220
and report items unique to the first list passed to the constructor.
2221
2222
=item * C
2223
2224
To get those items which appear in any list I
2225
list,> provide C with that list's index position in
2226
the list of arguments passed to the constructor (not counting any
2227
C<'-u'> or C<'--unsorted'> option).
2228
2229
Example: C<@Don> has index position C<3> in the constructor's C<@_>.
2230
To get elements not found in C<@Don>:
2231
2232
@Ronly = $lcm->get_complement(3);
2233
2234
If no index position is passed to C it will default to
2235
0 and report items found in any list other than the first list passed
2236
to the constructor.
2237
2238
=item * C
2239
2240
Get those items each of which appears in I of the lists
2241
passed to the constructor (their symmetric_difference);
2242
2243
@LorRonly = $lcm->get_symmetric_difference;
2244
2245
=item * C
2246
2247
Make a bag of all items found in any list. The bag differs from the
2248
lists' union in that it holds as many copies of individual elements
2249
as appear in the original lists.
2250
2251
@bag = $lcm->get_bag;
2252
2253
=item * Return reference instead of list
2254
2255
An alternative approach to the above methods: If you do not immediately
2256
require an array as the return value of the method call, but simply need
2257
a I to an array, use one of the following parallel methods:
2258
2259
$intersection_ref = $lcm->get_intersection_ref;
2260
$union_ref = $lcm->get_union_ref;
2261
$Lonly_ref = $lcm->get_unique_ref(2);
2262
$Ronly_ref = $lcm->get_complement_ref(3);
2263
$LorRonly_ref = $lcm->get_symmetric_difference_ref;
2264
$bag_ref = $lcm->get_bag_ref;
2265
2266
=item * C
2267
2268
To determine whether one particular list is a subset of another list
2269
passed to the constructor, provide C with the index
2270
position of the presumed subset (ignoring any unsorted option), followed
2271
by the index position of the presumed superset.
2272
2273
Example: To determine whether C<@Ed> is a subset of C<@Carmen>, call:
2274
2275
$LR = $lcm->is_LsubsetR(4,2);
2276
2277
A true value (C<1>) is returned if the left-hand list is a subset of the
2278
right-hand list; a false value (C<0>) is returned otherwise.
2279
2280
If no arguments are passed, C defaults to C<(0,1)> and
2281
compares the first two lists passed to the constructor.
2282
2283
=item * C
2284
2285
To determine whether any two particular lists are equivalent to each
2286
other, provide C with their index positions in the
2287
list of arguments passed to the constructor (ignoring any unsorted option).
2288
2289
Example: To determine whether C<@Don> and C<@Ed> are equivalent, call:
2290
2291
$eqv = $lcm->is_LequivalentR(3,4);
2292
2293
A true value (C<1>) is returned if the lists are equivalent; a false value
2294
(C<0>) otherwise.
2295
2296
If no arguments are passed, C defaults to C<(0,1)> and
2297
compares the first two lists passed to the constructor.
2298
2299
=item * C
2300
2301
To determine whether any two particular lists are disjoint from each other
2302
(I have no members in common), provide C with their
2303
index positions in the list of arguments passed to the constructor
2304
(ignoring any unsorted option).
2305
2306
Example: To determine whether C<@Don> and C<@Ed> are disjoint, call:
2307
2308
$disj = $lcm->is_LdisjointR(3,4);
2309
2310
A true value (C<1>) is returned if the lists are equivalent; a false value
2311
(C<0>) otherwise.
2312
2313
If no arguments are passed, C defaults to C<(0,1)> and
2314
compares the first two lists passed to the constructor.
2315
2316
=item * C
2317
2318
Pretty-print a chart showing the subset relationships among the various
2319
source lists:
2320
2321
$lcm->print_subset_chart;
2322
2323
=item * C
2324
2325
Pretty-print a chart showing the equivalence relationships among the
2326
various source lists:
2327
2328
$lcm->print_equivalence_chart;
2329
2330
=item * C
2331
2332
Determine in I (if any) of the lists passed to the constructor a given
2333
string can be found. In list context, return a list of those indices in the
2334
constructor's argument list (ignoring any unsorted option) corresponding to i
2335
lists holding the string being tested.
2336
2337
@memb_arr = $lcm->is_member_which('abel');
2338
2339
In the example above, C<@memb_arr> will be:
2340
2341
( 0 )
2342
2343
because C<'abel'> is found only in C<@Al> which holds position C<0> in the
2344
list of arguments passed to C.
2345
2346
=item * C
2347
2348
As with other List::Compare methods which return a list, you may wish the
2349
above method returned a (scalar) reference to an array holding the list:
2350
2351
$memb_arr_ref = $lcm->is_member_which_ref('jerky');
2352
2353
In the example above, C<$memb_arr_ref> will be:
2354
2355
[ 3, 4 ]
2356
2357
because C<'jerky'> is found in C<@Don> and C<@Ed>, which hold positions
2358
C<3> and C<4>, respectively, in the list of arguments passed to C.
2359
2360
B methods C and C test
2361
only one string at a time and hence take only one argument. To test more
2362
than one string at a time see the next method, C.
2363
2364
=item * C
2365
2366
Determine in C (if any) of the lists passed to the constructor one or
2367
more given strings can be found. The strings to be tested are placed in an
2368
anonymous array, a reference to which is passed to the method.
2369
2370
$memb_hash_ref =
2371
$lcm->are_members_which([ qw| abel baker fargo hilton zebra | ]);
2372
2373
I In versions of List::Compare prior to 0.25 (April 2004), the
2374
strings to be tested could be passed as a flat list. This is no longer
2375
possible; the argument must now be a reference to an anonymous array.
2376
2377
The return value is a reference to a hash of arrays. The
2378
key for each element in this hash is the string being tested. Each element's
2379
value is a reference to an anonymous array whose elements are those indices in
2380
the constructor's argument list corresponding to lists holding the strings
2381
being tested.
2382
2383
In the two examples above, C<$memb_hash_ref> will be:
2384
2385
{
2386
abel => [ 0 ],
2387
baker => [ 0, 1 ],
2388
fargo => [ 0, 1, 2, 3, 4 ],
2389
hilton => [ 1, 2 ],
2390
zebra => [ ],
2391
};
2392
2393
B C can take more than one argument;
2394
C and C each take only one argument.
2395
C returns a hash reference; the other methods return
2396
either a list or a reference to an array holding that list, depending on
2397
context.
2398
2399
=item * C
2400
2401
Determine whether a given string can be found in I of the lists passed as
2402
arguments to the constructor.
2403
2404
$found = $lcm->is_member_any('abel');
2405
2406
Return C<1> if a specified string can be found in I of the lists
2407
and C<0> if not.
2408
2409
In the example above, C<$found> will be C<1> because C<'abel'> is found in one
2410
or more of the lists passed as arguments to C.
2411
2412
=item * C
2413
2414
Determine whether a specified string or strings can be found in I of the
2415
lists passed as arguments to the constructor. The strings to be tested are
2416
placed in an array (anonymous or named), a reference to which is passed to
2417
the method.
2418
2419
$memb_hash_ref = $lcm->are_members_any([ qw| abel baker fargo hilton zebra | ]);
2420
2421
I In versions of List::Compare prior to 0.25 (April 2004), the
2422
strings to be tested could be passed as a flat list. This is no longer
2423
possible; the argument must now be a reference to an anonymous array.
2424
2425
The return value is a reference to a hash where an element's key is the
2426
string being tested and the element's value is 1 if the string can be
2427
found in C of the lists and 0 if not.
2428
In the two examples above, C<$memb_hash_ref> will be:
2429
2430
{
2431
abel => 1,
2432
baker => 1,
2433
fargo => 1,
2434
hilton => 1,
2435
zebra => 0,
2436
};
2437
2438
C's value will be C<0> because C is not found in any of the
2439
lists passed as arguments to C.
2440
2441
=item * C
2442
2443
Return current List::Compare version number:
2444
2445
$vers = $lcm->get_version;
2446
2447
=back
2448
2449
=item * Multiple Mode Methods Not Analogous to Regular and Accelerated Mode Methods
2450
2451
=over 4
2452
2453
=item * C
2454
2455
Get those items found in I of the lists passed to the constructor which
2456
do I appear in I of the lists (I all items except those found
2457
in the intersection of the lists):
2458
2459
@nonintersection = $lcm->get_nonintersection;
2460
2461
=item * C
2462
2463
Get those items which appear in more than one of the lists passed to the
2464
constructor (I all items except those found in their symmetric
2465
difference);
2466
2467
@shared = $lcm->get_shared;
2468
2469
=item * C
2470
2471
If you only need a reference to an array as a return value rather than a
2472
full array, use the following alternative methods:
2473
2474
$nonintersection_ref = $lcm->get_nonintersection_ref;
2475
$shared_ref = $lcm->get_shared_ref;
2476
2477
=item * C
2478
2479
Get a reference to an array of array references where each of the interior
2480
arrays holds the list of those items I to the list passed to the
2481
constructor with the same index position.
2482
2483
$unique_all_ref = $lcm->get_unique_all();
2484
2485
In the example above, C<$unique_all_ref> will hold:
2486
2487
[
2488
[ qw| abel | ],
2489
[ ],
2490
[ qw| jerky | ],
2491
[ ],
2492
[ ],
2493
]
2494
2495
=item * C
2496
2497
Get a reference to an array of array references where each of the interior
2498
arrays holds the list of those items in the I to the list
2499
passed to the constructor with the same index position.
2500
2501
$complement_all_ref = $lcm->get_complement_all();
2502
2503
In the example above, C<$complement_all_ref> will hold:
2504
2505
[
2506
[ qw| hilton icon jerky | ],
2507
[ qw| abel icon jerky | ],
2508
[ qw| abel baker camera delta edward | ],
2509
[ qw| abel baker camera delta edward jerky | ],
2510
[ qw| abel baker camera delta edward jerky | ],
2511
]
2512
2513
=back
2514
2515
=back
2516
2517
=head2 Multiple Accelerated Case: Compare Three or More Lists but Request Only a Single Comparison among the Lists
2518
2519
=over 4
2520
2521
=item * Constructor C
2522
2523
If you are certain that you will only want the results of a single
2524
comparison among three or more lists, computation may be accelerated
2525
by passing C<'-a'> or C<'--accelerated> as the first argument to
2526
the constructor.
2527
2528
@Al = qw(abel abel baker camera delta edward fargo golfer);
2529
@Bob = qw(baker camera delta delta edward fargo golfer hilton);
2530
@Carmen = qw(fargo golfer hilton icon icon jerky kappa);
2531
@Don = qw(fargo icon jerky);
2532
@Ed = qw(fargo icon icon jerky);
2533
2534
$lcma = List::Compare->new('-a',
2535
\@Al, \@Bob, \@Carmen, \@Don, \@Ed);
2536
2537
As with List::Compare's other cases, should you not need to have
2538
a sorted list returned by a List::Compare method, you may achieve a
2539
speed boost by constructing the object with the unsorted option:
2540
2541
$lcma = List::Compare->new('-u', '-a',
2542
\@Al, \@Bob, \@Carmen, \@Don, \@Ed);
2543
2544
or
2545
2546
$lcma = List::Compare->new('--unsorted', '--accelerated',
2547
\@Al, \@Bob, \@Carmen, \@Don, \@Ed);
2548
2549
As was the case with List::Compare's Multiple mode, do not count the
2550
unsorted option (C<'-u'> or C<'--unsorted'>) or the accelerated option
2551
(C<'-a'> or C<'--accelerated'>) when determining the index position of
2552
a particular list in the list of array references passed to the constructor.
2553
2554
Example:
2555
2556
$lcmaex = List::Compare->new('--unsorted', '--accelerated',
2557
\@alpha, \@beta, \@gamma);
2558
2559
=item * Alternative Constructor
2560
2561
The 'single hashref' format may be used to construct a List::Compare
2562
object which calls for accelerated processing of three or more lists at once:
2563
2564
$lcmaex = List::Compare->new( {
2565
accelerated => 1,
2566
lists => [\@alpha, \@beta, \@gamma],
2567
} );
2568
2569
or
2570
2571
$lcmaex = List::Compare->new( {
2572
unsorted => 1,
2573
accelerated => 1,
2574
lists => [\@alpha, \@beta, \@gamma],
2575
} );
2576
2577
=item * Methods
2578
2579
For the purpose of supplying a numerical argument to a method which
2580
optionally takes such an argument, C<'--unsorted'> and C<'--accelerated>
2581
are skipped, C<@alpha> is C<0>, C<@beta> is C<1>, and so forth. To get a
2582
list of those items unique to C<@gamma>, you would call:
2583
2584
@gamma_only = $lcmaex->get_unique(2);
2585
2586
=back
2587
2588
=head2 Passing Seen-hashes to the Constructor Instead of Arrays
2589
2590
=over 4
2591
2592
=item * When Seen-Hashes Are Already Available to You
2593
2594
Suppose that in a particular Perl program, you had to do extensive munging of
2595
data from an external source and that, once you had correctly parsed a line
2596
of data, it was easier to assign that datum to a hash than to an array.
2597
More specifically, suppose that you used each datum as the key to an element
2598
of a lookup table in the form of a I:
2599
2600
my %Llist = (
2601
abel => 2,
2602
baker => 1,
2603
camera => 1,
2604
delta => 1,
2605
edward => 1,
2606
fargo => 1,
2607
golfer => 1,
2608
);
2609
2610
my %Rlist = (
2611
baker => 1,
2612
camera => 1,
2613
delta => 2,
2614
edward => 1,
2615
fargo => 1,
2616
golfer => 1,
2617
hilton => 1,
2618
);
2619
2620
In other words, suppose it was more convenient to compute a lookup table
2621
I a list than to compute that list explicitly.
2622
2623
Since in almost all cases List::Compare takes the elements in the arrays
2624
passed to its constructor and I assigns them to elements in a
2625
seen-hash, why shouldn't you be able to pass (references to) seen-hashes
2626
I to the constructor and avoid unnecessary array
2627
assignments before the constructor is called?
2628
2629
=item * Constructor C
2630
2631
You can now do so:
2632
2633
$lcsh = List::Compare->new(\%Llist, \%Rlist);
2634
2635
=item * Methods
2636
2637
I of List::Compare's output methods are supported I
2638
modification> when references to seen-hashes are passed to the constructor.
2639
2640
@intersection = $lcsh->get_intersection;
2641
@union = $lcsh->get_union;
2642
@Lonly = $lcsh->get_unique;
2643
@Ronly = $lcsh->get_complement;
2644
@LorRonly = $lcsh->get_symmetric_difference;
2645
@bag = $lcsh->get_bag;
2646
$intersection_ref = $lcsh->get_intersection_ref;
2647
$union_ref = $lcsh->get_union_ref;
2648
$Lonly_ref = $lcsh->get_unique_ref;
2649
$Ronly_ref = $lcsh->get_complement_ref;
2650
$LorRonly_ref = $lcsh->get_symmetric_difference_ref;
2651
$bag_ref = $lcsh->get_bag_ref;
2652
$LR = $lcsh->is_LsubsetR;
2653
$RL = $lcsh->is_RsubsetL;
2654
$eqv = $lcsh->is_LequivalentR;
2655
$disj = $lcsh->is_LdisjointR;
2656
$lcsh->print_subset_chart;
2657
$lcsh->print_equivalence_chart;
2658
@memb_arr = $lsch->is_member_which('abel');
2659
$memb_arr_ref = $lsch->is_member_which_ref('baker');
2660
$memb_hash_ref = $lsch->are_members_which(
2661
[ qw| abel baker fargo hilton zebra | ]);
2662
$found = $lsch->is_member_any('abel');
2663
$memb_hash_ref = $lsch->are_members_any(
2664
[ qw| abel baker fargo hilton zebra | ]);
2665
$vers = $lcsh->get_version;
2666
$unique_all_ref = $lcsh->get_unique_all();
2667
$complement_all_ref = $lcsh->get_complement_all();
2668
2669
=item * Accelerated Mode and Seen-Hashes
2670
2671
To accelerate processing when you want only a single comparison among two or
2672
more lists, you can pass C<'-a'> or C<'--accelerated> to the constructor
2673
before passing references to seen-hashes.
2674
2675
$lcsha = List::Compare->new('-a', \%Llist, \%Rlist);
2676
2677
To compare three or more lists simultaneously, pass three or more references
2678
to seen-hashes. Thus,
2679
2680
$lcshm = List::Compare->new(\%Alpha, \%Beta, \%Gamma);
2681
2682
will generate meaningful comparisons of three or more lists simultaneously.
2683
2684
=item * Unsorted Results and Seen-Hashes
2685
2686
If you do not need sorted lists returned, pass C<'-u'> or C<--unsorted> to the
2687
constructor before passing references to seen-hashes.
2688
2689
$lcshu = List::Compare->new('-u', \%Llist, \%Rlist);
2690
$lcshau = List::Compare->new('-u', '-a', \%Llist, \%Rlist);
2691
$lcshmu = List::Compare->new('--unsorted', \%Alpha, \%Beta, \%Gamma);
2692
2693
As was true when we were using List::Compare's Multiple and Multiple Accelerated
2694
modes, do not count any unsorted or accelerated option when determining the
2695
array index of a particular seen-hash reference passed to the constructor.
2696
2697
=item * Alternative Constructor
2698
2699
The 'single hashref' form of constructor is also available to build
2700
List::Compare objects where seen-hashes are used as arguments:
2701
2702
$lcshu = List::Compare->new( {
2703
unsorted => 1,
2704
lists => [\%Llist, \%Rlist],
2705
} );
2706
2707
$lcshau = List::Compare->new( {
2708
unsorted => 1,
2709
accelerated => 1,
2710
lists => [\%Llist, \%Rlist],
2711
} );
2712
2713
$lcshmu = List::Compare->new( {
2714
unsorted => 1,
2715
lists => [\%Alpha, \%Beta, \%Gamma],
2716
} );
2717
2718
=back
2719
2720
=head1 DISCUSSION: Principles
2721
2722
=head2 General Comments
2723
2724
List::Compare is an object-oriented implementation of very common Perl
2725
code (see "History, References and Development" below) used to
2726
determine interesting relationships between two or more lists at a time.
2727
A List::Compare object is created and automatically computes the values
2728
needed to supply List::Compare methods with appropriate results. In the
2729
current implementation List::Compare methods will return new lists
2730
containing the items found in any designated list alone (unique), any list
2731
other than a designated list (complement), the intersection and union of
2732
all lists and so forth. List::Compare also has (a) methods to return Boolean
2733
values indicating whether one list is a subset of another and whether any
2734
two lists are equivalent to each other (b) methods to pretty-print very
2735
simple charts displaying the subset and equivalence relationships among
2736
lists.
2737
2738
Except for List::Compare's C method, B
2739
an element in a given list count only once with
2740
respect to computing the intersection, union, etc. of the two lists.> In
2741
particular, List::Compare considers two lists as equivalent if each element
2742
of the first list can be found in the second list and I.
2743
'Equivalence' in this usage takes no note of the frequency with which
2744
elements occur in either list or their order within the lists. List::Compare
2745
asks the question: I Only when
2746
you use C to compute a bag holding the two lists do you
2747
ask the question: How many times did this item occur in this list?
2748
2749
=head2 List::Compare Modes
2750
2751
In its current implementation List::Compare has four modes of operation.
2752
2753
=over 4
2754
2755
=item *
2756
2757
Regular Mode
2758
2759
List::Compare's Regular mode is based on List::Compare v0.11 -- the first
2760
version of List::Compare released to CPAN (June 2002). It compares only
2761
two lists at a time. Internally, its initializer does all computations
2762
needed to report any desired comparison and its constructor stores the
2763
results of these computations. Its public methods merely report these
2764
results.
2765
2766
This approach has the advantage that if you need to examine more
2767
than one form of comparison between two lists (I the union,
2768
intersection and symmetric difference of two lists), the comparisons are
2769
pre-calculated. This approach is efficient because certain types of
2770
comparison presuppose that other types have already been calculated.
2771
For example, to calculate the symmetric difference of two lists, one must
2772
first determine the items unique to each of the two lists.
2773
2774
=item *
2775
2776
Accelerated Mode
2777
2778
The current implementation of List::Compare offers you the option of
2779
getting even faster results I that you only need the
2780
result from a I form of comparison between two lists. (I only
2781
the union -- nothing else). In the Accelerated mode, List::Compare's
2782
initializer does no computation and its constructor stores only references
2783
to the two source lists. All computation needed to report results is
2784
deferred to the method calls.
2785
2786
The user selects this approach by passing the option flag C<'-a'> to the
2787
constructor before passing references to the two source lists.
2788
List::Compare notes the option flag and silently switches into Accelerated
2789
mode. From the perspective of the user, there is no further difference in
2790
the code or in the results.
2791
2792
Benchmarking suggests that List::Compare's Accelerated mode (a) is faster
2793
than its Regular mode when only one comparison is requested; (b) is about as
2794
fast as Regular mode when two comparisons are requested; and (c) becomes
2795
considerably slower than Regular mode as each additional comparison above two
2796
is requested.
2797
2798
=item *
2799
2800
Multiple Mode
2801
2802
List::Compare now offers the possibility of comparing three or more lists at
2803
a time. Simply store the extra lists in arrays and pass references to those
2804
arrays to the constructor. List::Compare detects that more than two lists
2805
have been passed to the constructor and silently switches into Multiple mode.
2806
2807
As described in the Synopsis above, comparing more than two lists at a time
2808
offers you a wider, more complex palette of comparison methods.
2809
Individual items may appear in just one source list, in all the source lists,
2810
or in some number of lists between one and all. The meaning of 'union',
2811
'intersection' and 'symmetric difference' is conceptually unchanged
2812
when you move to multiple lists because these are properties of all the lists
2813
considered together. In contrast, the meaning of 'unique', 'complement',
2814
'subset' and 'equivalent' changes because these are properties of one list
2815
compared with another or with all the other lists combined.
2816
2817
List::Compare takes this complexity into account by allowing you to pass
2818
arguments to the public methods requesting results with respect to a specific
2819
list (for C and C) or a specific pair of lists
2820
(for C and C).
2821
2822
List::Compare further takes this complexity into account by offering the
2823
new methods C and C described in the
2824
Synopsis above.
2825
2826
=item *
2827
2828
Multiple Accelerated Mode
2829
2830
Beginning with version 0.25, introduced in April 2004, List::Compare
2831
offers the possibility of accelerated computation of a single comparison
2832
among three or more lists at a time. Simply store the extra lists in
2833
arrays and pass references to those arrays to the constructor preceded by
2834
the C<'-a'> argument as was done with the simple (two lists only)
2835
accelerated mode. List::Compare detects that more than two lists have been
2836
passed to the constructor and silently switches into Multiple Accelerated
2837
mode.
2838
2839
=item *
2840
2841
Unsorted Option
2842
2843
When List::Compare is used to return lists representing various comparisons
2844
of two or more lists (I, the lists' union or intersection), the lists
2845
returned are, by default, sorted using Perl's default C mode:
2846
ASCII-betical sorting. Sorting produces results which are more easily
2847
human-readable but may entail a performance cost.
2848
2849
Should you not need sorted results, you can avoid the potential
2850
performance cost by calling List::Compare's constructor using the unsorted
2851
option. This is done by calling C<'-u'> or C<'--unsorted'> as the first
2852
argument passed to the constructor, I, as an argument called before
2853
any references to lists are passed to the constructor.
2854
2855
Note that if are calling List::Compare in the Accelerated or Multiple
2856
Accelerated mode I wish to have the lists returned in unsorted order,
2857
you I pass the argument for the unsorted option
2858
(C<'-u'> or C<'--unsorted'>) and I pass the argument for the
2859
Accelerated mode (C<'-a'> or C<'--accelerated'>).
2860
2861
=back
2862
2863
=head2 Miscellaneous Methods
2864
2865
It would not really be appropriate to call C and
2866
C in Regular or Accelerated mode since they are
2867
conceptually based on the notion of comparing more than two lists at a time.
2868
However, there is always the possibility that a user may be comparing only two
2869
lists (accelerated or not) and may accidentally call one of those two methods.
2870
To prevent fatal run-time errors and to caution you to use a more
2871
appropriate method, these two methods are defined for Regular and Accelerated
2872
modes so as to return suitable results but also generate a carp message that
2873
advise you to re-code.
2874
2875
Similarly, the method C is appropriate for the Regular and
2876
Accelerated modes but is not really appropriate for Multiple mode. As a
2877
defensive maneuver, it has been defined for Multiple mode so as to return
2878
suitable results but also to generate a carp message that advises you to
2879
re-code.
2880
2881
In List::Compare v0.11 and earlier, the author provided aliases for various
2882
methods based on the supposition that the source lists would be referred to as
2883
'A' and 'B'. Now that you can compare more than two lists at a time, the author
2884
feels that it would be more appropriate to refer to the elements of two-argument
2885
lists as the left-hand and right-hand elements. Hence, we are discouraging the
2886
use of methods such as C, C and C as
2887
aliases for C, C and
2888
C. However, to guarantee backwards compatibility
2889
for the vast audience of Perl programmers using earlier versions of
2890
List::Compare (all 10e1 of you) these and similar methods for subset
2891
relationships are still defined.
2892
2893
=head2 List::Compare::SeenHash Discontinued Beginning with Version 0.26
2894
2895
Prior to v0.26, introduced April 11, 2004, if a user wished to pass
2896
references to seen-hashes to List::Compare's constructor rather than
2897
references to arrays, he or she had to call a different, parallel module:
2898
List::Compare::SeenHash. The code for that looked like this:
2899
2900
use List::Compare::SeenHash;
2901
2902
my %Llist = (
2903
abel => 2,
2904
baker => 1,
2905
camera => 1,
2906
delta => 1,
2907
edward => 1,
2908
fargo => 1,
2909
golfer => 1,
2910
);
2911
2912
my %Rlist = (
2913
baker => 1,
2914
camera => 1,
2915
delta => 2,
2916
edward => 1,
2917
fargo => 1,
2918
golfer => 1,
2919
hilton => 1,
2920
);
2921
2922
my $lcsh = List::Compare::SeenHash->new(\%Llist, \%Rlist);
2923
2924
B All
2925
its functionality (and more) has been implemented in List::Compare itself,
2926
since a user can now pass I a series of array references I a
2927
series of seen-hash references to List::Compare's constructor.
2928
2929
To simplify future maintenance of List::Compare, List::Compare::SeenHash.pm
2930
will no longer be distributed with List::Compare, nor will the files in the
2931
test suite which tested List::Compare::SeenHash upon installation be distributed.
2932
2933
Should you still need List::Compare::SeenHash, use version 0.25 from CPAN, or
2934
simply edit your Perl programs which used List::Compare::SeenHash. Those
2935
scripts may be edited quickly with, for example, this editing command in
2936
Unix text editor F:
2937
2938
:1,$s/List::Compare::SeenHash/List::Compare/gc
2939
2940
=head2 A Non-Object-Oriented Interface: List::Compare::Functional
2941
2942
Version 0.21 of List::Compare introduced List::Compare::Functional,
2943
a functional (I, non-object-oriented) interface to list comparison
2944
functions. List::Compare::Functional supports the same functions currently
2945
supported by List::Compare. It works similar to List::Compare's Accelerated
2946
and Multiple Accelerated modes (described above), bit it does not
2947
require use of the C<'-a'> flag in the function call.
2948
List::Compare::Functional will return unsorted comparisons of two lists by
2949
passing C<'-u'> or C<'--unsorted'> as the first argument to the function.
2950
Please see the documentation for List::Compare::Functional to learn how to
2951
import its functions into your main package.
2952
2953
=head1 ASSUMPTIONS AND QUALIFICATIONS
2954
2955
The program was created with Perl 5.6. The use of I to prepare
2956
the module's template installed C at the top of the
2957
module. This has been commented out in the actual module as the code
2958
appears to be compatible with earlier versions of Perl; how earlier the
2959
author cannot say. In particular, the author would like the module to
2960
be installable on older versions of MacPerl. As is, the author has
2961
successfully installed the module on Linux, Windows 9x and Windows 2000.
2962
See L for
2963
a list of other systems on which this version of List::Compare has been
2964
tested and installed.
2965
2966
=head1 HISTORY, REFERENCES AND DEVELOPMENT
2967
2968
=head2 The Code Itself
2969
2970
List::Compare is based on code presented by Tom Christiansen & Nathan
2971
Torkington in I L
2972
(a.k.a. the 'Ram' book), O'Reilly & Associates, 1998, Recipes 4.7 and 4.8.
2973
Similar code is presented in the Camel book: I, by Larry
2974
Wall, Tom Christiansen, Jon Orwant.
2975
L , 3rd ed, O'Reilly & Associates,
2976
2000. The list comparison code is so basic and Perlish that I suspect it
2977
may have been written by Larry himself at the dawn of Perl time. The
2978
C method was inspired by Jarkko Hietaniemi's Set::Bag module
2979
and Daniel Berger's Set::Array module, both available on CPAN.
2980
2981
List::Compare's original objective was simply to put this code in a modular,
2982
object-oriented framework. That framework, not surprisingly, is taken mostly
2983
from Damian Conway's I
2984
L, Manning Publications, 2000.
2985
2986
With the addition of the Accelerated, Multiple and Multiple Accelerated
2987
modes, List::Compare expands considerably in both size and capabilities.
2988
Nonetheless, Tom and Nat's I code still lies at its core:
2989
the use of hashes as look-up tables to record elements seen in lists.
2990
Please note: List::Compare is not concerned with any concept of 'equality'
2991
among lists which hinges upon the frequency with which, or the order in
2992
which, elements appear in the lists to be compared. If this does not
2993
meet your needs, you should look elsewhere or write your own module.
2994
2995
=head2 The Inspiration
2996
2997
I realized the usefulness of putting the list comparison code into a
2998
module while preparing an introductory level Perl course given at the New
2999
School University's Computer Instruction Center in April-May 2002. I was
3000
comparing lists left and right. When I found myself writing very similar
3001
functions in different scripts, I knew a module was lurking somewhere.
3002
I learned the truth of the mantra ''Repeated Code is a Mistake'' from a
3003
2001 talk by Mark-Jason Dominus L to the New York
3004
Perlmongers L .
3005
See L.
3006
3007
The first public presentation of this module took place at Perl Seminar
3008
New York L on May 21, 2002.
3009
Comments and suggestions were provided there and since by Glenn Maciag,
3010
Gary Benson, Josh Rabinowitz, Terrence Brannon and Dave Cross.
3011
3012
The placement in the installation tree of Test::ListCompareSpecial came
3013
as a result of a question answered by Michael Graham in his talk
3014
''Test::More to Test::Extreme'' given at Yet Another Perl Conference::Canada
3015
in Ottawa, Ontario, on May 16, 2003.
3016
3017
In May-June 2003, Glenn Maciag made valuable suggestions which led to
3018
changes in method names and documentation in v0.20.
3019
3020
Another presentation at Perl Seminar New York in
3021
October 2003 prompted me to begin planning List::Compare::Functional.
3022
3023
In a November 2003 Perl Seminar New York presentation, Ben Holtzman
3024
discussed the performance costs entailed in Perl's C function.
3025
This led me to ask, ''Why should a user of List::Compare pay this performance
3026
cost if he or she doesn't need a human-readable list as a result (as
3027
would be the case if the list returned were used as the input into some
3028
other function)?'' This led to the development of List::Compare's
3029
unsorted option.
3030
3031
An April 2004 offer by Kevin Carlson to write an article for I
3032
(L) led me to re-think whether a separate module
3033
(the former List::Compare::SeenHash) was truly needed when a user wanted
3034
to provide the constructor with references to seen-hashes rather than
3035
references to arrays. Since I had already adapted List::Compare::Functional
3036
to accept both kinds of arguments, I adapted List::Compare in the same
3037
manner. This meant that List::Compare::SeenHash and its related installation
3038
tests could be deprecated and deleted from the CPAN distribution.
3039
3040
A remark by David H. Adler at a New York Perlmongers meeting in April 2004
3041
led me to develop the 'single hashref' alternative constructor format,
3042
introduced in version 0.29 the following month.
3043
3044
Presentations at two different editions of Yet Another Perl Conference (YAPC)
3045
inspired the development of List::Compare versions 0.30 and 0.31. I was
3046
selected to give a talk on List::Compare at YAPC::NA::2004 in Buffalo. This
3047
spurred me to improve certain aspects of the documentation. Version 0.31
3048
owes its inspiration to one talk at the Buffalo YAPC and one earlier talk at
3049
YAPC::EU::2003 in Paris. In Paris I heard Paul Johnson speak on his CPAN
3050
module Devel::Cover and on coverage analysis more generally. That material
3051
was over my head at that time, but in Buffalo I heard Andy Lester discuss
3052
Devel::Cover as part of his discussion of testing and of the Phalanx project
3053
(L). This time I got it, and when I returned
3054
from Buffalo I applied Devel::Cover to List::Compare and wrote additional tests
3055
to improve its subroutine and statement coverage. In addition, I added two
3056
new methods, C and C. In writing these
3057
two methods, I followed a model of test-driven development much more so than
3058
in earlier versions of List::Compare and my other CPAN modules. The result?
3059
List::Compare's test suite grew by over 3300 tests to nearly 23,000 tests.
3060
3061
At the Second New York Perl Hackathon (May 02 2015), a project was created to
3062
request performance improvements in certain List::Compare functions
3063
(L).
3064
Hackathon participant Michael Rawson submitted a pull request with changes to
3065
List::Compare::Base::_Auxiliary. After these revisions were benchmarked, a
3066
patch embodying the pull request was accepted, leading to CPAN version 0.53.
3067
3068
=head2 If You Like List::Compare, You'll Love ...
3069
3070
While preparing this module for distribution via CPAN, I had occasion to
3071
study a number of other modules already available on CPAN. Each of these
3072
modules is more sophisticated than List::Compare -- which is not surprising
3073
since all that List::Compare originally aspired to do was to avoid typing
3074
Cookbook code repeatedly. Here is a brief description of the features of
3075
these modules. (B The following discussion is only valid as
3076
of June 2002. Some of these modules may have changed since then.)
3077
3078
=over 4
3079
3080
=item *
3081
3082
Algorithm::Diff - Compute 'intelligent' differences between two files/lists
3083
(L )
3084
3085
Algorithm::Diff is a sophisticated module originally written by Mark-Jason
3086
Dominus, later maintained by Ned Konz, now maintained by Tye McQueen. Think of
3087
the Unix C utility and you're on the right track. Algorithm::Diff
3088
exports
3089
methods such as C, which ''computes the smallest set of additions and
3090
deletions necessary to turn the first sequence into the second, and returns a
3091
description of these changes.'' Algorithm::Diff is mainly concerned with the
3092
sequence of elements within two lists. It does not export functions for
3093
intersection, union, subset status, etc.
3094
3095
=item *
3096
3097
Array::Compare - Perl extension for comparing arrays
3098
(L )
3099
3100
Array::Compare, by Dave Cross, asks whether two arrays
3101
are the same or different by doing a C on each string with a
3102
separator character and comparing the resulting strings. Like
3103
List::Compare, it is an object-oriented module. A sophisticated feature of
3104
Array::Compare is that it allows you to specify how 'whitespace' in an
3105
array (an element which is undefined, the empty string, or whitespace
3106
within an element) should be evaluated for purpose of determining equality
3107
or difference. It does not directly provide methods for intersection and
3108
union.
3109
3110
=item *
3111
3112
Data::Compare - compare perl data structures
3113
(L )
3114
3115
This library compares Perl data structures recursively. Comes recommended by
3116
Slaven Rezić!
3117
3118
=item *
3119
3120
List::Util - A selection of general-utility list subroutines
3121
(L )
3122
3123
List::Util, by Graham Barr, exports a variety of simple,
3124
useful functions for operating on one list at a time. The C function
3125
returns the lowest numerical value in a list; the C function returns
3126
the highest value; and so forth. List::Compare differs from List::Util in
3127
that it is object-oriented and that it works on two strings at a time
3128
rather than just one -- but it aims to be as simple and useful as
3129
List::Util. List::Util will be included in the standard Perl
3130
distribution as of Perl 5.8.0.
3131
3132
Lists::Util (L ),
3133
by Tassilo von Parseval, building on code by Terrence Brannon, provides
3134
methods
3135
which extend List::Util's functionality.
3136
3137
=item *
3138
3139
Quantum::Superpositions
3140
(L ),
3141
originally by Damian Conway, now maintained by Steven Lembark is useful if, in
3142
addition to comparing lists, you need to emulate quantum supercomputing as
3143
well.
3144
Not for the eigen-challenged.
3145
3146
=item *
3147
3148
Set::Scalar - basic set operations
3149
(L )
3150
3151
Set::Bag - bag (multiset) class
3152
(L )
3153
3154
Both of these modules are by Jarkko Hietaniemi. Set::Scalar
3155
has methods to return the intersection, union, difference and symmetric
3156
difference of two sets, as well as methods to return items unique to a
3157
first set and complementary to it in a second set. It has methods for
3158
reporting considerably more variants on subset status than does
3159
List::Compare. However, benchmarking suggests that List::Compare, at
3160
least in Regular mode, is considerably faster than Set::Scalar for those
3161
comparison methods which List::Compare makes available.
3162
3163
Set::Bag enables one to deal more flexibly with the situation in which one
3164
has more than one instance of an element in a list.
3165
3166
=item *
3167
3168
Set::Array - Arrays as objects with lots of handy methods (including set
3169
comparisons) and support for method chaining.
3170
(L )
3171
3172
Set::Array, by Daniel Berger, now maintained by Ron Savage, ''aims to provide
3173
built-in methods for operations that people are always asking how to do,and
3174
which already exist in languages like Ruby.'' Among the many methods in
3175
this module are some for intersection, union, etc. To install Set::Array,
3176
you must first install the Want module, also available on CPAN.
3177
3178
=back
3179
3180
=head1 ADDITIONAL CONTRIBUTORS
3181
3182
=over 4
3183
3184
=item * Syohei YOSHIDA
3185
3186
Pull request accepted May 22 2015.
3187
3188
=item * Paulo Custodio
3189
3190
Pull request accepted June 07 2015, correcting errors in C<_subset_subengine()>.
3191
3192
=back
3193
3194
=head1 BUGS
3195
3196
There are no bug reports outstanding on List::Compare as of the most recent
3197
CPAN upload date of this distribution.
3198
3199
=head1 SUPPORT
3200
3201
Please report any bugs by mail to C
3202
or through the web interface at L.
3203
3204
=head1 AUTHOR
3205
3206
James E. Keenan (jkeenan@cpan.org). When sending correspondence, please
3207
include 'List::Compare' or 'List-Compare' in your subject line.
3208
3209
Creation date: May 20, 2002. Last modification date: August 16 2020.
3210
3211
Development repository: L
3212
3213
=head1 COPYRIGHT
3214
3215
Copyright (c) 2002-20 James E. Keenan. United States. All rights reserved.
3216
This is free software and may be distributed under the same terms as Perl
3217
itself.
3218
3219
=head1 DISCLAIMER OF WARRANTY
3220
3221
BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
3222
FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
3223
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
3224
PROVIDE THE SOFTWARE ''AS IS'' WITHOUT WARRANTY OF ANY KIND, EITHER
3225
EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
3226
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
3227
ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
3228
YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
3229
NECESSARY SERVICING, REPAIR, OR CORRECTION.
3230
3231
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
3232
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
3233
REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
3234
LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
3235
OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
3236
THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
3237
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
3238
FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
3239
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
3240
SUCH DAMAGES.
3241
3242
=cut
3243