line
stmt
bran
cond
sub
pod
time
code
1
package List::Compare;
2
our $VERSION = '0.54';
3
34
34
2382977
use strict;
34
354
34
1301
4
local $^W = 1;
5
34
34
195
use Carp;
34
65
34
2418
6
34
44698
use List::Compare::Base::_Auxiliary qw(
7
_validate_2_seenhashes
8
_chart_engine_regular
9
34
34
18088
);
34
100
10
11
sub new {
12
212
212
1
81450
my $class = shift;
13
212
511
my (@args, $unsorted, $accelerated, $argument_error_status, $nextarg, @testargs);
14
212
100
100
1097
if (@_ == 1 and (ref($_[0]) eq 'HASH')) {
15
89
183
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
139
unless exists ${$argref}{'lists'};
89
310
18
die "Need to define 'lists' key properly: $!"
19
88
325
unless ( ${$argref}{'lists'}
20
88
100
100
160
and (ref(${$argref}{'lists'}) eq 'ARRAY') );
87
344
21
86
162
@args = @{${$argref}{'lists'}};
86
136
86
247
22
86
100
139
$unsorted = ${$argref}{'unsorted'} ? 1 : '';
86
238
23
86
100
150
$accelerated = ${$argref}{'accelerated'} ? 1 : '';
86
256
24
} else {
25
123
323
@args = @_;
26
123
100
100
639
$unsorted = ($args[0] eq '-u' or $args[0] eq '--unsorted')
27
? shift(@args) : '';
28
123
100
100
612
$accelerated = shift(@args)
29
if ($args[0] eq '-a' or $args[0] eq '--accelerated');
30
}
31
209
369
$argument_error_status = 1;
32
209
651
@testargs = @args[1..$#args];
33
209
100
100
965
if (ref($args[0]) eq 'ARRAY' or ref($args[0]) eq 'HASH') {
34
195
548
while (defined ($nextarg = shift(@testargs))) {
35
339
100
1149
unless (ref($nextarg) eq ref($args[0])) {
36
16
37
$argument_error_status = 0;
37
16
36
last;
38
}
39
}
40
} else {
41
14
50
$argument_error_status = 0;
42
}
43
209
100
3542
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
566
if (@args > 2) {
100
48
43
100
113
if ($accelerated) {
49
22
73
$class .= '::Multiple::Accelerated';
50
} else {
51
21
69
$class .= '::Multiple';
52
}
53
} elsif (@args == 2) {
54
129
100
262
if ($accelerated) {
55
61
195
$class .= '::Accelerated';
56
}
57
} else {
58
7
694
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
531
my $self = bless {}, $class;
64
172
100
815
my $dataref = $self->_init(($unsorted ? 1 : 0), @args);
65
66
# initialize the object from the prepared values (Damian, p. 98)
67
162
1133
%$self = %$dataref;
68
162
907
return $self;
69
}
70
71
sub _init {
72
68
68
118
my $self = shift;
73
68
138
my ($unsortflag, $refL, $refR) = @_;
74
68
117
my (%data, @left, @right, %seenL, %seenR);
75
68
100
223
if (ref($refL) eq 'HASH') {
76
27
127
my ($seenLref, $seenRref) = _validate_2_seenhashes($refL, $refR);
77
23
47
foreach my $key (keys %{$seenLref}) {
23
77
78
116
174
for (my $j=1; $j <= ${$seenLref}{$key}; $j++) {
255
497
79
139
234
push(@left, $key);
80
}
81
}
82
23
59
foreach my $key (keys %{$seenRref}) {
23
72
83
105
157
for (my $j=1; $j <= ${$seenRref}{$key}; $j++) {
228
440
84
123
202
push(@right, $key);
85
}
86
}
87
23
46
%seenL = %{$seenLref};
23
118
88
23
48
%seenR = %{$seenRref};
23
118
89
} else {
90
41
93
foreach (@$refL) { $seenL{$_}++ }
160
281
91
41
81
foreach (@$refR) { $seenR{$_}++ }
149
235
92
41
92
@left = @$refL;
93
41
84
@right = @$refR;
94
}
95
64
100
347
my @bag = $unsortflag ? (@left, @right) : sort(@left, @right);
96
64
128
my (%intersection, %union, %Lonly, %Ronly, %LorRonly);
97
64
121
my $LsubsetR_status = my $RsubsetL_status = 1;
98
64
85
my $LequivalentR_status = 0;
99
100
64
256
foreach (keys %seenL) {
101
252
453
$union{$_}++;
102
252
100
549
exists $seenR{$_} ? $intersection{$_}++ : $Lonly{$_}++;
103
}
104
105
64
245
foreach (keys %seenR) {
106
235
318
$union{$_}++;
107
235
100
479
$Ronly{$_}++ unless (exists $intersection{$_});
108
}
109
110
64
241
$LorRonly{$_}++ foreach ( (keys %Lonly), (keys %Ronly) );
111
112
64
100
193
$LequivalentR_status = 1 if ( (keys %LorRonly) == 0);
113
114
64
131
foreach (@left) {
115
183
100
345
if (! exists $seenR{$_}) {
116
39
62
$LsubsetR_status = 0;
117
39
77
last;
118
}
119
}
120
64
125
foreach (@right) {
121
222
100
426
if (! exists $seenL{$_}) {
122
32
57
$RsubsetL_status = 0;
123
32
56
last;
124
}
125
}
126
127
64
153
$data{'seenL'} = \%seenL;
128
64
111
$data{'seenR'} = \%seenR;
129
64
100
268
$data{'intersection'} = $unsortflag ? [ keys %intersection ]
130
: [ sort keys %intersection ];
131
64
100
315
$data{'union'} = $unsortflag ? [ keys %union ]
132
: [ sort keys %union ];
133
64
100
219
$data{'unique'} = $unsortflag ? [ keys %Lonly ]
134
: [ sort keys %Lonly ];
135
64
100
222
$data{'complement'} = $unsortflag ? [ keys %Ronly ]
136
: [ sort keys %Ronly ];
137
64
100
238
$data{'symmetric_difference'} = $unsortflag ? [ keys %LorRonly ]
138
: [ sort keys %LorRonly ];
139
64
190
$data{'LsubsetR_status'} = $LsubsetR_status;
140
64
105
$data{'RsubsetL_status'} = $RsubsetL_status;
141
64
117
$data{'LequivalentR_status'} = $LequivalentR_status;
142
64
100
193
$data{'LdisjointR_status'} = keys %intersection == 0 ? 1 : 0;
143
64
107
$data{'bag'} = \@bag;
144
64
296
return \%data;
145
}
146
147
sub get_intersection {
148
26
26
1
9600
return @{ get_intersection_ref(shift) };
26
104
149
}
150
151
sub get_intersection_ref {
152
52
52
0
5826
my $class = shift;
153
52
360
my %data = %$class;
154
52
404
return $data{'intersection'};
155
}
156
157
sub get_union {
158
8
8
1
6545
return @{ get_union_ref(shift) };
8
33
159
}
160
161
sub get_union_ref {
162
16
16
0
6831
my $class = shift;
163
16
109
my %data = %$class;
164
16
94
return $data{'union'};
165
}
166
167
sub get_shared {
168
8
8
1
21337
my $class = shift;
169
8
59
my $method = (caller(0))[3];
170
8
1742
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
861
get_intersection($class);
172
}
173
174
sub get_shared_ref {
175
8
8
0
36383
my $class = shift;
176
8
62
my $method = (caller(0))[3];
177
8
889
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
497
get_intersection_ref($class);
179
}
180
181
sub get_unique {
182
24
24
1
35531
return @{ get_unique_ref(shift) };
24
84
183
}
184
185
sub get_unique_ref {
186
48
48
0
18013
my $class = shift;
187
48
297
my %data = %$class;
188
48
242
return $data{'unique'};
189
}
190
191
sub get_unique_all {
192
8
8
1
5837
my $class = shift;
193
8
68
my %data = %$class;
194
8
51
return [ $data{'unique'}, $data{'complement'} ];
195
}
196
197
{
198
34
34
323
no warnings 'once';
34
80
34
7092
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
18878
return @{ get_complement_ref(shift) };
24
76
207
}
208
209
sub get_complement_ref {
210
48
48
0
17543
my $class = shift;
211
48
283
my %data = %$class;
212
48
216
return $data{'complement'};
213
}
214
215
sub get_complement_all {
216
8
8
1
5735
my $class = shift;
217
8
64
my %data = %$class;
218
8
45
return [ $data{'complement'}, $data{'unique'} ];
219
}
220
221
{
222
34
34
309
no warnings 'once';
34
101
34
5321
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
24063
return @{ get_symmetric_difference_ref(shift) };
40
158
231
}
232
233
sub get_symmetric_difference_ref {
234
80
80
0
23897
my $class = shift;
235
80
469
my %data = %$class;
236
80
516
return $data{'symmetric_difference'};
237
}
238
239
{
240
34
34
259
no warnings 'once';
34
77
34
9415
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
14339
my $class = shift;
251
8
59
my $method = (caller(0))[3];
252
8
1077
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
508
get_symmetric_difference($class);
254
}
255
256
sub get_nonintersection_ref {
257
8
8
1
31199
my $class = shift;
258
8
56
my $method = (caller(0))[3];
259
8
808
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
479
get_symmetric_difference_ref($class);
261
}
262
263
sub is_LsubsetR {
264
48
48
1
16416
my $class = shift;
265
48
285
my %data = %$class;
266
48
206
return $data{'LsubsetR_status'};
267
}
268
269
34
34
296
{ no warnings 'once'; *is_AsubsetB = \&is_LsubsetR; }
34
85
34
3096
270
271
sub is_RsubsetL {
272
48
48
0
13147
my $class = shift;
273
48
277
my %data = %$class;
274
48
196
return $data{'RsubsetL_status'};
275
}
276
277
34
34
244
{ no warnings 'once'; *is_BsubsetA = \&is_RsubsetL; }
34
65
34
2924
278
279
sub is_LequivalentR {
280
48
48
1
16340
my $class = shift;
281
48
313
my %data = %$class;
282
48
211
return $data{'LequivalentR_status'};
283
}
284
285
34
34
226
{ no warnings 'once'; *is_LeqvlntR = \&is_LequivalentR; }
34
88
34
30566
286
287
sub is_LdisjointR {
288
34
34
1
8244
my $class = shift;
289
34
212
my %data = %$class;
290
34
150
return $data{'LdisjointR_status'};
291
}
292
293
sub print_subset_chart {
294
8
8
1
11191
my $class = shift;
295
8
69
my %data = %$class;
296
8
119
my @subset_array = ($data{'LsubsetR_status'}, $data{'RsubsetL_status'});
297
8
28
my $title = 'Subset';
298
8
136
_chart_engine_regular(\@subset_array, $title);
299
}
300
301
sub print_equivalence_chart {
302
8
8
1
27801
my $class = shift;
303
8
74
my %data = %$class;
304
my @equivalent_array = ($data{'LequivalentR_status'},
305
8
42
$data{'LequivalentR_status'});
306
8
20
my $title = 'Equivalence';
307
8
36
_chart_engine_regular(\@equivalent_array, $title);
308
}
309
310
sub is_member_which {
311
92
92
1
22137
return @{ is_member_which_ref(@_) };
92
162
312
}
313
314
sub is_member_which_ref {
315
185
185
1
8149
my $class = shift;
316
185
100
100
1507
croak "Method call requires exactly 1 argument (no references): $!"
317
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
318
176
672
my %data = %$class;
319
176
335
my $arg = shift;
320
176
261
my @found = ();
321
176
100
279
if (exists ${$data{'seenL'}}{$arg}) { push @found, 0; }
176
368
112
265
322
176
100
263
if (exists ${$data{'seenR'}}{$arg}) { push @found, 1; }
176
373
112
196
323
176
574
return \@found;
324
}
325
326
sub are_members_which {
327
13
13
1
6860
my $class = shift;
328
13
100
100
521
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
70
my %data = %$class;
331
8
28
my (@args, %found);
332
8
18
@args = @{$_[0]};
8
74
333
8
47
for (my $i=0; $i<=$#args; $i++) {
334
88
118
@{$found{$args[$i]}} = ();
88
197
335
88
100
150
if (exists ${$data{'seenL'}}{$args[$i]}) { push @{$found{$args[$i]}}, 0; }
88
185
56
81
56
104
336
88
100
110
if (exists ${$data{'seenR'}}{$args[$i]}) { push @{$found{$args[$i]}}, 1; }
88
219
56
74
56
177
337
}
338
8
51
return \%found;
339
}
340
341
sub is_member_any {
342
93
93
1
7508
my $class = shift;
343
93
100
100
708
croak "Method call requires exactly 1 argument (no references): $!"
344
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
345
88
410
my %data = %$class;
346
88
168
my $arg = shift;
347
( defined $data{'seenL'}{$arg} ) ||
348
88
100
100
487
( defined $data{'seenR'}{$arg} ) ? return 1 : return 0;
349
}
350
351
sub are_members_any {
352
13
13
1
6475
my $class = shift;
353
13
100
100
484
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
76
my %data = %$class;
356
8
27
my (@args, %present);
357
8
20
@args = @{$_[0]};
8
37
358
8
48
for (my $i=0; $i<=$#args; $i++) {
359
$present{$args[$i]} = ( defined $data{'seenL'}{$args[$i]} ) ||
360
88
100
100
375
( defined $data{'seenR'}{$args[$i]} ) ? 1 : 0;
361
}
362
8
70
return \%present;
363
}
364
365
sub get_bag {
366
8
8
1
22557
return @{ get_bag_ref(shift) };
8
42
367
}
368
369
sub get_bag_ref {
370
16
16
0
6856
my $class = shift;
371
16
111
my %data = %$class;
372
16
168
return $data{'bag'};
373
}
374
375
sub get_version {
376
8
8
1
4373
return $List::Compare::VERSION;
377
}
378
379
1;
380
381
################################################################################
382
383
package List::Compare::Accelerated;
384
34
34
285
use Carp;
34
80
34
2349
385
34
21841
use List::Compare::Base::_Auxiliary qw(
386
_argument_checker_0
387
_chart_engine_regular
388
_calc_seen
389
_equiv_engine
390
34
34
260
);
34
87
391
392
sub _init {
393
61
61
100
my $self = shift;
394
61
121
my ($unsortflag, $refL, $refR) = @_;
395
61
103
my %data = ();
396
61
175
($data{'L'}, $data{'R'}) = _argument_checker_0($refL, $refR);
397
57
100
151
$data{'unsort'} = $unsortflag ? 1 : 0;
398
57
124
return \%data;
399
}
400
401
sub get_intersection {
402
14
14
23594
return @{ get_intersection_ref(shift) };
14
56
403
}
404
405
sub get_intersection_ref {
406
28
28
5909
my $class = shift;
407
28
111
my %data = %$class;
408
$data{'unsort'}
409
? return _intersection_engine($data{'L'}, $data{'R'})
410
28
100
140
: return [ sort @{_intersection_engine($data{'L'}, $data{'R'})} ];
16
52
411
}
412
413
sub get_union {
414
8
8
4186
return @{ get_union_ref(shift) };
8
38
415
}
416
417
sub get_union_ref {
418
32
32
6435
my $class = shift;
419
32
130
my %data = %$class;
420
$data{'unsort'}
421
? return _union_engine($data{'L'}, $data{'R'})
422
32
100
141
: return [ sort @{_union_engine($data{'L'}, $data{'R'})} ];
16
49
423
}
424
425
sub get_shared {
426
8
8
16758
return @{ get_shared_ref(shift) };
8
39
427
}
428
429
sub get_shared_ref {
430
16
16
54866
my $class = shift;
431
16
149
my $method = (caller(0))[3];
432
16
136
$method =~ s/.*::(\w*)$/$1/;
433
16
2321
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
1169
&get_union_ref($class);
435
}
436
437
sub get_unique {
438
24
24
16879
return @{ get_unique_ref(shift) };
24
67
439
}
440
441
sub get_unique_ref {
442
64
64
16554
my $class = shift;
443
64
214
my %data = %$class;
444
$data{'unsort'}
445
? return _unique_engine($data{'L'}, $data{'R'})
446
64
100
218
: return [ sort @{_unique_engine($data{'L'}, $data{'R'})} ];
32
78
447
}
448
449
sub get_unique_all {
450
8
8
5382
my $class = shift;
451
8
31
return [ get_unique_ref($class), get_complement_ref($class) ];
452
}
453
454
{
455
34
34
297
no warnings 'once';
34
76
34
7349
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
17964
return @{ get_complement_ref(shift) };
24
109
464
}
465
466
sub get_complement_ref {
467
64
64
16660
my $class = shift;
468
64
214
my %data = %$class;
469
$data{'unsort'}
470
? return _complement_engine($data{'L'}, $data{'R'})
471
64
100
212
: return [ sort @{_complement_engine($data{'L'}, $data{'R'})} ];
32
90
472
}
473
474
sub get_complement_all {
475
8
8
5443
my $class = shift;
476
8
31
return [ get_complement_ref($class), get_unique_ref($class) ];
477
}
478
479
{
480
34
34
250
no warnings 'once';
34
72
34
6241
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
23577
return @{ get_symmetric_difference_ref(shift) };
32
86
489
}
490
491
sub get_symmetric_difference_ref {
492
80
80
22002
my $class = shift;
493
80
305
my %data = %$class;
494
$data{'unsort'}
495
? return _symmetric_difference_engine($data{'L'}, $data{'R'})
496
80
100
266
: return [ sort @{_symmetric_difference_engine($data{'L'}, $data{'R'})} ];
40
98
497
}
498
499
{
500
34
34
283
no warnings 'once';
34
114
34
8017
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
14462
return @{ get_nonintersection_ref(shift) };
8
53
511
}
512
513
sub get_nonintersection_ref {
514
16
16
30383
my $class = shift;
515
16
101
my $method = (caller(0))[3];
516
16
150
$method =~ s/.*::(\w*)$/$1/;
517
16
2079
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
967
&get_symmetric_difference_ref($class);
519
}
520
521
sub is_LsubsetR {
522
38
38
14403
my $class = shift;
523
38
195
my %data = %$class;
524
38
129
return _is_LsubsetR_engine($data{'L'}, $data{'R'});
525
}
526
527
34
34
248
{ no warnings 'once'; *is_AsubsetB = \&is_LsubsetR; }
34
61
34
3381
528
529
sub is_RsubsetL {
530
38
38
11251
my $class = shift;
531
38
149
my %data = %$class;
532
38
135
return _is_RsubsetL_engine($data{'L'}, $data{'R'});
533
}
534
535
34
34
248
{ no warnings 'once'; *is_BsubsetA = \&is_RsubsetL; }
34
67
34
3038
536
537
sub is_LequivalentR {
538
48
48
14603
my $class = shift;
539
48
186
my %data = %$class;
540
48
146
return _is_LequivalentR_engine($data{'L'}, $data{'R'});
541
}
542
543
34
34
240
{ no warnings 'once'; *is_LeqvlntR = \&is_LequivalentR; }
34
80
34
77592
544
545
sub is_LdisjointR {
546
30
30
7091
my $class = shift;
547
30
122
my %data = %$class;
548
30
115
return _is_LdisjointR_engine($data{'L'}, $data{'R'});
549
}
550
551
sub print_subset_chart {
552
8
8
10539
my $class = shift;
553
8
42
my %data = %$class;
554
8
48
_print_subset_chart_engine($data{'L'}, $data{'R'});
555
}
556
557
sub print_equivalence_chart {
558
8
8
25444
my $class = shift;
559
8
47
my %data = %$class;
560
8
45
_print_equivalence_chart_engine($data{'L'}, $data{'R'});
561
}
562
563
sub is_member_which {
564
92
92
20857
return @{ is_member_which_ref(@_) };
92
178
565
}
566
567
sub is_member_which_ref {
568
185
185
7418
my $class = shift;
569
185
100
100
1469
croak "Method call requires exactly 1 argument (no references): $!"
570
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
571
176
411
my %data = %$class;
572
176
361
return _is_member_which_engine($data{'L'}, $data{'R'}, shift);
573
}
574
575
sub are_members_which {
576
13
13
6245
my $class = shift;
577
13
100
100
462
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
45
my %data = %$class;
580
8
20
my (@args);
581
8
20
@args = @{$_[0]};
8
33
582
8
38
return _are_members_which_engine($data{'L'}, $data{'R'}, \@args);
583
}
584
585
sub is_member_any {
586
93
93
6759
my $class = shift;
587
93
100
100
681
croak "Method call requires exactly 1 argument (no references): $!"
588
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
589
88
199
my %data = %$class;
590
88
199
return _is_member_any_engine($data{'L'}, $data{'R'}, shift);
591
}
592
593
sub are_members_any {
594
13
13
6021
my $class = shift;
595
13
100
100
465
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
40
my %data = %$class;
598
8
24
my (@args);
599
8
18
@args = @{$_[0]};
8
31
600
8
53
return _are_members_any_engine($data{'L'}, $data{'R'}, \@args);
601
}
602
603
sub get_bag {
604
8
8
21059
return @{ get_bag_ref(shift) };
8
38
605
}
606
607
sub get_bag_ref {
608
16
16
6213
my $class = shift;
609
16
121
my %data = %$class;
610
16
100
80
if (ref($data{'L'}) eq 'ARRAY') {
611
4
10
$data{'unsort'} ? return [ @{$data{'L'}}, @{$data{'R'}} ]
4
29
612
8
100
27
: return [ sort(@{$data{'L'}}, @{$data{'R'}}) ];
4
8
4
43
613
} else {
614
8
22
my (@left, @right);
615
8
14
foreach my $key (keys %{$data{'L'}}) {
8
32
616
56
122
for (my $j=1; $j <= ${$data{'L'}}{$key}; $j++) {
120
242
617
64
109
push(@left, $key);
618
}
619
}
620
8
55
foreach my $key (keys %{$data{'R'}}) {
8
28
621
56
142
for (my $j=1; $j <= ${$data{'R'}}{$key}; $j++) {
120
230
622
64
105
push(@right, $key);
623
}
624
}
625
8
100
137
$data{'unsort'} ? return [ @left, @right ]
626
: return [ sort(@left, @right) ];
627
}
628
}
629
630
sub get_version {
631
8
8
4203
return $List::Compare::VERSION;
632
}
633
634
sub _intersection_engine {
635
28
28
67
my ($l, $r) = @_;
636
28
91
my ($hrefL, $hrefR) = _calc_seen($l, $r);
637
28
73
my %intersection = ();
638
28
49
foreach (keys %{$hrefL}) {
28
100
639
160
100
189
$intersection{$_}++ if (exists ${$hrefR}{$_});
160
358
640
}
641
28
262
return [ keys %intersection ];
642
}
643
644
sub _union_engine {
645
32
32
76
my ($l, $r) = @_;
646
32
104
my ($hrefL, $hrefR) = _calc_seen($l, $r);
647
32
62
my %union = ();
648
32
62
$union{$_}++ foreach ( (keys %{$hrefL}), (keys %{$hrefR}) );
32
94
32
230
649
32
406
return [ keys %union ];
650
}
651
652
sub _unique_engine {
653
64
64
117
my ($l, $r) = @_;
654
64
176
my ($hrefL, $hrefR) = _calc_seen($l, $r);
655
64
113
my (%Lonly);
656
64
83
foreach (keys %{$hrefL}) {
64
196
657
448
100
508
$Lonly{$_}++ unless exists ${$hrefR}{$_};
448
887
658
}
659
64
425
return [ keys %Lonly ];
660
}
661
662
sub _complement_engine {
663
64
64
114
my ($l, $r) = @_;
664
64
173
my ($hrefL, $hrefR) = _calc_seen($l, $r);
665
64
108
my (%Ronly);
666
64
85
foreach (keys %{$hrefR}) {
64
195
667
448
100
546
$Ronly{$_}++ unless (exists ${$hrefL}{$_});
448
859
668
}
669
64
433
return [ keys %Ronly ];
670
}
671
672
sub _symmetric_difference_engine {
673
80
80
148
my ($l, $r) = @_;
674
80
237
my ($hrefL, $hrefR) = _calc_seen($l, $r);
675
80
144
my (%LorRonly);
676
80
114
foreach (keys %{$hrefL}) {
80
238
677
560
100
664
$LorRonly{$_}++ unless (exists ${$hrefR}{$_});
560
1141
678
}
679
80
131
foreach (keys %{$hrefR}) {
80
208
680
560
100
632
$LorRonly{$_}++ unless (exists ${$hrefL}{$_});
560
1002
681
}
682
80
646
return [ keys %LorRonly ];
683
}
684
685
sub _is_LsubsetR_engine {
686
38
38
83
my ($l, $r) = @_;
687
38
222
my ($hrefL, $hrefR) = _calc_seen($l, $r);
688
38
67
my $LsubsetR_status = 1;
689
38
68
foreach (keys %{$hrefL}) {
38
124
690
128
100
163
if (! exists ${$hrefR}{$_}) {
128
374
691
32
49
$LsubsetR_status = 0;
692
32
97
last;
693
}
694
}
695
38
161
return $LsubsetR_status;
696
}
697
698
sub _is_RsubsetL_engine {
699
38
38
113
my ($l, $r) = @_;
700
38
110
my ($hrefL, $hrefR) = _calc_seen($l, $r);
701
38
121
my $RsubsetL_status = 1;
702
38
69
foreach (keys %{$hrefR}) {
38
152
703
129
100
189
if (! exists ${$hrefL}{$_}) {
129
284
704
22
35
$RsubsetL_status = 0;
705
22
54
last;
706
}
707
}
708
38
149
return $RsubsetL_status;
709
}
710
711
sub _is_LequivalentR_engine {
712
48
48
95
my ($l, $r) = @_;
713
48
160
my ($hrefL, $hrefR) = _calc_seen($l, $r);
714
48
134
return _equiv_engine($hrefL, $hrefR);
715
}
716
717
sub _is_LdisjointR_engine {
718
30
30
64
my ($l, $r) = @_;
719
30
93
my ($hrefL, $hrefR) = _calc_seen($l, $r);
720
30
76
my %intersection = ();
721
30
62
foreach (keys %{$hrefL}) {
30
92
722
152
100
189
$intersection{$_}++ if (exists ${$hrefR}{$_});
152
345
723
}
724
30
100
221
keys %intersection == 0 ? 1 : 0;
725
}
726
727
sub _print_subset_chart_engine {
728
8
8
32
my ($l, $r) = @_;
729
8
34
my ($hrefL, $hrefR) = _calc_seen($l, $r);
730
8
35
my $LsubsetR_status = my $RsubsetL_status = 1;
731
8
19
foreach (keys %{$hrefL}) {
8
58
732
40
100
50
if (! exists ${$hrefR}{$_}) {
40
102
733
8
30
$LsubsetR_status = 0;
734
8
21
last;
735
}
736
}
737
8
21
foreach (keys %{$hrefR}) {
8
30
738
31
100
44
if (! exists ${$hrefL}{$_}) {
31
66
739
8
14
$RsubsetL_status = 0;
740
8
28
last;
741
}
742
}
743
8
38
my @subset_array = ($LsubsetR_status, $RsubsetL_status);
744
8
25
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
32
my ($hrefL, $hrefR) = _calc_seen($l, $r);
751
8
33
my $LequivalentR_status = _equiv_engine($hrefL, $hrefR);
752
8
32
my @equivalent_array = ($LequivalentR_status, $LequivalentR_status);
753
8
19
my $title = 'Equivalence';
754
8
30
_chart_engine_regular(\@equivalent_array, $title);
755
}
756
757
sub _is_member_which_engine {
758
176
176
279
my ($l, $r, $arg) = @_;
759
176
337
my ($hrefL, $hrefR) = _calc_seen($l, $r);
760
176
259
my @found = ();
761
176
100
213
if (exists ${$hrefL}{$arg}) { push @found, 0; }
176
374
112
185
762
176
100
229
if (exists ${$hrefR}{$arg}) { push @found, 1; }
176
298
112
157
763
176
656
return \@found;
764
}
765
766
sub _are_members_which_engine {
767
8
8
25
my ($l, $r, $arg) = @_;
768
8
32
my ($hrefL, $hrefR) = _calc_seen($l, $r);
769
8
20
my @args = @{$arg};
8
30
770
8
18
my (%found);
771
8
36
for (my $i=0; $i<=$#args; $i++) {
772
88
116
@{$found{$args[$i]}} = ();
88
178
773
88
100
115
if (exists ${$hrefL}{$args[$i]}) { push @{$found{$args[$i]}}, 0; }
88
175
56
85
56
104
774
88
100
114
if (exists ${$hrefR}{$args[$i]}) { push @{$found{$args[$i]}}, 1; }
88
194
56
70
56
118
775
}
776
8
45
return \%found;
777
}
778
779
sub _is_member_any_engine {
780
88
88
146
my ($l, $r, $arg) = @_;
781
88
174
my ($hrefL, $hrefR) = _calc_seen($l, $r);
782
( defined ${$hrefL}{$arg} ) ||
783
88
100
100
123
( defined ${$hrefR}{$arg} ) ? return 1 : return 0;
784
}
785
786
sub _are_members_any_engine {
787
8
8
26
my ($l, $r, $arg) = @_;
788
8
35
my ($hrefL, $hrefR) = _calc_seen($l, $r);
789
8
21
my @args = @{$arg};
8
31
790
8
17
my (%present);
791
8
36
for (my $i=0; $i<=$#args; $i++) {
792
$present{$args[$i]} = ( defined ${$hrefL}{$args[$i]} ) ||
793
88
100
100
111
( defined ${$hrefR}{$args[$i]} ) ? 1 : 0;
794
}
795
8
65
return \%present;
796
}
797
798
1;
799
800
################################################################################
801
802
package List::Compare::Multiple;
803
34
34
297
use Carp;
34
705
34
2443
804
34
60412
use List::Compare::Base::_Auxiliary qw(
805
_validate_seen_hash
806
_index_message1
807
_index_message2
808
_chart_engine_multiple
809
34
34
247
);
34
60
810
811
sub _init {
812
21
21
48
my $self = shift;
813
21
37
my $unsortflag = shift;
814
21
56
my @listrefs = @_;
815
21
46
my (@arrayrefs);
816
21
45
my $maxindex = $#listrefs;
817
21
100
78
if (ref($listrefs[0]) eq 'ARRAY') {
818
10
28
@arrayrefs = @listrefs;
819
} else {
820
11
55
_validate_seen_hash(@listrefs);
821
9
33
foreach my $href (@listrefs) {
822
49
68
my (@temp);
823
49
76
foreach my $key (keys %{$href}) {
49
116
824
255
333
for (my $j=1; $j <= ${$href}{$key}; $j++) {
555
977
825
300
526
push(@temp, $key);
826
}
827
}
828
49
114
push(@arrayrefs, \@temp);
829
}
830
}
831
832
19
44
my @bag = ();
833
19
55
foreach my $aref (@arrayrefs) {
834
101
415
push @bag, $_ foreach @$aref;
835
}
836
19
100
172
@bag = sort(@bag) unless $unsortflag;
837
838
19
41
my (@intersection, @union);
839
# will hold overall intersection/union
840
19
44
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
35
my (%intersection, %union);
850
# will be used to generate @intersection & @union
851
19
50
my %seen = ();
852
# will be hash of hashes, holding seen-hashes corresponding to
853
# the source lists
854
19
35
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
39
my %shared = ();
859
# will be used to generate @shared
860
19
41
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
61
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
48
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
74
for (my $i = 0; $i <= $#arrayrefs; $i++) {
874
101
175
my %seenthis = ();
875
101
160
foreach (@{$arrayrefs[$i]}) {
101
183
876
606
858
$seenthis{$_}++;
877
606
816
$union{$_}++;
878
}
879
101
265
$seen{$i} = \%seenthis;
880
101
282
for (my $j = $i+1; $j <=$#arrayrefs; $j++) {
881
223
313
my (%seenthat, %seenintersect);
882
223
377
my $ilabel = $i . '_' . $j;
883
223
300
$seenthat{$_}++ foreach (@{$arrayrefs[$j]});
223
676
884
223
525
foreach (keys %seenthat) {
885
938
100
1705
$seenintersect{$_}++ if (exists $seenthis{$_});
886
}
887
223
924
$xintersection{$ilabel} = \%seenintersect;
888
}
889
}
890
19
100
180
@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
131
my @xkeys = keys %xintersection;
898
19
47
%intersection = %{$xintersection{$xkeys[0]}};
19
91
899
19
90
for (my $m = 1; $m <= $#xkeys; $m++) {
900
204
283
my %compare = %{$xintersection{$xkeys[$m]}};
204
596
901
204
301
my %result = ();
902
204
382
foreach (keys %compare) {
903
548
100
927
$result{$_}++ if (exists $intersection{$_});
904
}
905
204
572
%intersection = %result;
906
}
907
19
100
93
@intersection = $unsortflag ? keys %intersection : sort(keys %intersection);
908
909
# Calculate nonintersection
910
# Inputs: @union %intersection
911
19
54
foreach (@union) {
912
207
100
424
push(@nonintersection, $_) unless (exists $intersection{$_});
913
}
914
915
# Calculate @xunique and @xdisjoint
916
# Inputs: @arrayrefs %seen %xintersection
917
19
100
for (my $i = 0; $i <= $#arrayrefs; $i++) {
918
101
158
my %seenthis = %{$seen{$i}};
101
428
919
101
207
my (@uniquethis, %deductions, %alldeductions);
920
# Get those elements of %xintersection which we'll need
921
# to subtract from %seenthis
922
101
287
foreach (keys %xintersection) {
923
1229
2546
my ($left, $right) = split /_/, $_;
924
1229
100
100
3363
if ($left == $i || $right == $i) {
925
446
636
$deductions{$_} = $xintersection{$_};
926
}
927
$xdisjoint[$left][$right] = $xdisjoint[$right][$left] =
928
1229
100
1403
! (keys %{$xintersection{$_}}) ? 1 : 0;
1229
2860
929
}
930
101
281
foreach my $ded (keys %deductions) {
931
446
527
foreach (keys %{$deductions{$ded}}) {
446
771
932
1196
1754
$alldeductions{$_}++;
933
}
934
}
935
101
261
foreach (keys %seenthis) {
936
516
100
927
push(@uniquethis, $_) unless ($alldeductions{$_});
937
}
938
101
192
$xunique[$i] = \@uniquethis;
939
101
349
$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
91
for (my $i = 0; $i <= $#arrayrefs; $i++) {
947
101
126
my %seenthis = %{$seen{$i}};
101
328
948
101
164
my @complementthis = ();
949
101
163
foreach (@union) {
950
1133
100
1957
push(@complementthis, $_) unless (exists $seenthis{$_});
951
}
952
101
282
$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
108
foreach my $q (keys %xintersection) {
961
223
268
$shared{$_}++ foreach (keys %{$xintersection{$q}});
223
599
962
}
963
19
100
154
@shared = $unsortflag ? keys %shared : sort(keys %shared);
964
19
59
foreach (@union) {
965
207
100
410
push(@symmetric_difference, $_) unless (exists $shared{$_});
966
}
967
# @shared and @symmetric_difference are now available.
968
969
19
59
my @xsubset = ();
970
19
82
foreach my $i (keys %seen) {
971
101
133
my %tempi = %{$seen{$i}};
101
285
972
101
232
foreach my $j (keys %seen) {
973
547
678
my %tempj = %{$seen{$j}};
547
1406
974
547
990
$xsubset[$i][$j] = 1;
975
547
1049
foreach (keys %tempi) {
976
2808
100
5652
$xsubset[$i][$j] = 0 if (! $tempj{$_});
977
}
978
}
979
}
980
# @xsubset is now available
981
982
19
53
my @xequivalent = ();
983
19
79
for (my $f = 0; $f <= $#xsubset; $f++) {
984
101
198
for (my $g = 0; $g <= $#xsubset; $g++) {
985
547
726
$xequivalent[$f][$g] = 0;
986
547
100
100
1385
$xequivalent[$f][$g] = 1
987
if ($xsubset[$f][$g] and $xsubset[$g][$f]);
988
}
989
}
990
991
19
65
my (%data);
992
19
52
$data{'seen'} = \%seen;
993
19
44
$data{'maxindex'} = $maxindex;
994
19
58
$data{'intersection'} = \@intersection;
995
19
43
$data{'nonintersection'} = \@nonintersection;
996
19
45
$data{'union'} = \@union;
997
19
43
$data{'shared'} = \@shared;
998
19
73
$data{'symmetric_difference'} = \@symmetric_difference;
999
19
48
$data{'xunique'} = \@xunique;
1000
19
41
$data{'xcomplement'} = \@xcomplement;
1001
19
47
$data{'xsubset'} = \@xsubset;
1002
19
44
$data{'xequivalent'} = \@xequivalent;
1003
19
53
$data{'xdisjoint'} = \@xdisjoint;
1004
19
134
$data{'bag'} = \@bag;
1005
19
261
return \%data;
1006
}
1007
1008
sub get_intersection {
1009
8
8
5625
return @{ get_intersection_ref(shift) };
8
39
1010
}
1011
1012
sub get_intersection_ref {
1013
16
16
5279
my $class = shift;
1014
16
194
my %data = %$class;
1015
16
91
return $data{'intersection'};
1016
}
1017
1018
sub get_union {
1019
8
8
4171
return @{ get_union_ref(shift) };
8
29
1020
}
1021
1022
sub get_union_ref {
1023
16
16
6453
my $class = shift;
1024
16
197
my %data = %$class;
1025
16
95
return $data{'union'};
1026
}
1027
1028
sub get_shared {
1029
8
8
5862
return @{ get_shared_ref(shift) };
8
133
1030
}
1031
1032
sub get_shared_ref {
1033
16
16
5591
my $class = shift;
1034
16
148
my %data = %$class;
1035
16
87
return $data{'shared'};
1036
}
1037
1038
sub get_unique {
1039
36
36
15719
my $class = shift;
1040
36
277
my %data = %$class;
1041
36
100
145
my $index = defined $_[0] ? shift : 0;
1042
36
56
return @{ get_unique_ref($class, $index) };
36
87
1043
}
1044
1045
sub get_unique_ref {
1046
77
77
10010
my $class = shift;
1047
77
435
my %data = %$class;
1048
77
100
342
my $index = defined $_[0] ? shift : 0;
1049
77
310
_index_message1($index, \%data);
1050
72
122
return ${$data{'xunique'}}[$index];
72
564
1051
}
1052
1053
sub get_unique_all {
1054
8
8
20479
my $class = shift;
1055
8
73
my %data = %$class;
1056
8
42
return $data{'xunique'};
1057
}
1058
1059
sub get_Lonly {
1060
24
24
69247
my ($class, $index) = @_;
1061
24
179
my $method = (caller(0))[3];
1062
24
285
$method =~ s/.*::(\w*)$/$1/;
1063
24
2642
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
1835
get_unique($class, $index);
1065
}
1066
1067
sub get_Lonly_ref {
1068
24
24
144244
my ($class, $index) = @_;
1069
24
154
my $method = (caller(0))[3];
1070
24
231
$method =~ s/.*::(\w*)$/$1/;
1071
24
2267
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
1501
get_unique_ref($class, $index);
1073
}
1074
1075
{
1076
34
34
306
no warnings 'once';
34
73
34
15209
1077
*get_Aonly = \&get_Lonly;
1078
*get_Aonly_ref = \&get_Lonly_ref;
1079
}
1080
1081
sub get_complement {
1082
44
44
31737
my $class = shift;
1083
44
319
my %data = %$class;
1084
44
100
179
my $index = defined $_[0] ? shift : 0;
1085
44
73
return @{ get_complement_ref($class, $index) };
44
102
1086
}
1087
1088
sub get_complement_ref {
1089
93
93
14002
my $class = shift;
1090
93
522
my %data = %$class;
1091
93
100
277
my $index = defined $_[0] ? shift : 0;
1092
93
338
_index_message1($index, \%data);
1093
88
149
return ${$data{'xcomplement'}}[$index];
88
767
1094
}
1095
1096
sub get_complement_all {
1097
8
8
17937
my $class = shift;
1098
8
71
my %data = %$class;
1099
8
42
return $data{'xcomplement'};
1100
}
1101
1102
sub get_Ronly {
1103
28
28
69830
my ($class, $index) = @_;
1104
28
181
my $method = (caller(0))[3];
1105
28
236
$method =~ s/.*::(\w*)$/$1/;
1106
28
2540
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
1943
&get_complement($class, $index);
1108
}
1109
1110
sub get_Ronly_ref {
1111
28
28
99095
my ($class, $index) = @_;
1112
28
186
my $method = (caller(0))[3];
1113
28
251
$method =~ s/.*::(\w*)$/$1/;
1114
28
2477
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
1604
&get_complement_ref($class, $index);
1116
}
1117
1118
{
1119
34
34
311
no warnings 'once';
34
107
34
4679
1120
*get_Bonly = \&get_Ronly;
1121
*get_Bonly_ref = \&get_Ronly_ref;
1122
}
1123
1124
sub get_symmetric_difference {
1125
32
32
21442
return @{ get_symmetric_difference_ref(shift) };
32
94
1126
}
1127
1128
sub get_symmetric_difference_ref {
1129
64
64
10665
my $class = shift;
1130
64
431
my %data = %$class;
1131
64
418
return $data{'symmetric_difference'};
1132
}
1133
1134
{
1135
34
34
291
no warnings 'once';
34
94
34
7849
1136
*get_symdiff = \&get_symmetric_difference;
1137
*get_symdiff_ref = \&get_symmetric_difference_ref;
1138
}
1139
1140
sub get_LorRonly {
1141
16
16
38845
my $class = shift;
1142
16
105
my $method = (caller(0))[3];
1143
16
134
$method =~ s/.*::(\w*)$/$1/;
1144
16
1539
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
932
get_symmetric_difference($class);
1146
}
1147
1148
sub get_LorRonly_ref {
1149
16
16
74979
my $class = shift;
1150
16
113
my $method = (caller(0))[3];
1151
16
165
$method =~ s/.*::(\w*)$/$1/;
1152
16
1545
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
871
get_symmetric_difference_ref($class);
1154
}
1155
1156
{
1157
34
34
277
no warnings 'once';
34
88
34
7374
1158
*get_AorBonly = \&get_LorRonly;
1159
*get_AorBonly_ref = \&get_LorRonly_ref;
1160
}
1161
1162
sub get_nonintersection {
1163
8
8
16326
return @{ get_nonintersection_ref(shift) };
8
41
1164
}
1165
1166
sub get_nonintersection_ref {
1167
16
16
5693
my $class = shift;
1168
16
115
my %data = %$class;
1169
16
109
return $data{'nonintersection'};
1170
}
1171
1172
sub is_LsubsetR {
1173
57
57
22071
my $class = shift;
1174
57
380
my %data = %$class;
1175
57
243
my ($index_left, $index_right) = _index_message2(\%data, @_);
1176
48
91
my @subset_array = @{$data{'xsubset'}};
48
127
1177
48
100
my $subset_status = $subset_array[$index_left][$index_right];
1178
48
180
return $subset_status;
1179
}
1180
1181
34
34
292
{ no warnings 'once'; *is_AsubsetB = \&is_LsubsetR; }
34
92
34
6743
1182
1183
sub is_RsubsetL {
1184
16
16
36897
my $class = shift;
1185
16
132
my %data = %$class;
1186
16
109
my $method = (caller(0))[3];
1187
16
138
$method =~ s/.*::(\w*)$/$1/;
1188
16
1474
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
1106
@_ = (1,0);
1190
16
86
my ($index_left, $index_right) = _index_message2(\%data, @_);
1191
16
46
my @subset_array = @{$data{'xsubset'}};
16
55
1192
16
40
my $subset_status = $subset_array[$index_left][$index_right];
1193
16
112
return $subset_status;
1194
}
1195
1196
34
34
250
{ no warnings 'once'; *is_BsubsetA = \&is_RsubsetL; }
34
94
34
4348
1197
1198
sub is_LequivalentR {
1199
33
33
26045
my $class = shift;
1200
33
239
my %data = %$class;
1201
33
138
my ($index_left, $index_right) = _index_message2(\%data, @_);
1202
24
136
my @equivalent_array = @{$data{'xequivalent'}};
24
87
1203
24
55
my $equivalent_status = $equivalent_array[$index_left][$index_right];
1204
24
95
return $equivalent_status;
1205
}
1206
1207
34
34
236
{ no warnings 'once'; *is_LeqvlntR = \&is_LequivalentR; }
34
81
34
32685
1208
1209
sub is_LdisjointR {
1210
29
29
9140
my $class = shift;
1211
29
208
my %data = %$class;
1212
29
133
my ($index_left, $index_right) = _index_message2(\%data, @_);
1213
24
53
my @disjoint_array = @{$data{'xdisjoint'}};
24
90
1214
24
59
my $disjoint_status = $disjoint_array[$index_left][$index_right];
1215
24
102
return $disjoint_status;
1216
}
1217
1218
sub is_member_which {
1219
92
92
27355
return @{ is_member_which_ref(@_) };
92
180
1220
}
1221
1222
sub is_member_which_ref {
1223
185
185
21817
my $class = shift;
1224
185
100
100
1503
croak "Method call requires exactly 1 argument (no references): $!"
1225
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
1226
176
734
my %data = %$class;
1227
176
362
my %seen = %{$data{'seen'}};
176
479
1228
176
280
my ($arg, @found);
1229
176
373
$arg = shift;
1230
176
543
foreach (sort keys %seen) {
1231
880
100
1858
push @found, $_ if (exists $seen{$_}{$arg});
1232
}
1233
176
783
return \@found;
1234
}
1235
1236
sub are_members_which {
1237
13
13
21564
my $class = shift;
1238
13
100
100
476
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
76
my %data = %$class;
1241
8
29
my %seen = %{$data{'seen'}};
8
40
1242
8
27
my (@args, %found);
1243
8
18
@args = @{$_[0]};
8
32
1244
8
57
for (my $i=0; $i<=$#args; $i++) {
1245
88
128
my (@not_found);
1246
88
230
foreach (sort keys %seen) {
1247
440
835
exists ${$seen{$_}}{$args[$i]}
1248
440
100
519
? push @{$found{$args[$i]}}, $_
216
472
1249
: push @not_found, $_;
1250
}
1251
88
100
290
$found{$args[$i]} = [] if (@not_found == keys %seen);
1252
}
1253
8
49
return \%found;
1254
}
1255
1256
sub is_member_any {
1257
93
93
14942
my $class = shift;
1258
93
100
100
731
croak "Method call requires exactly 1 argument (no references): $!"
1259
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
1260
88
460
my %data = %$class;
1261
88
156
my %seen = %{$data{'seen'}};
88
232
1262
88
138
my ($arg, $k);
1263
88
146
$arg = shift;
1264
88
180
while ( $k = each %seen ) {
1265
185
100
607
return 1 if (defined $seen{$k}{$arg});
1266
}
1267
8
36
return 0;
1268
}
1269
1270
sub are_members_any {
1271
13
13
7088
my $class = shift;
1272
13
100
100
490
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
99
my %data = %$class;
1275
8
28
my %seen = %{$data{'seen'}};
8
43
1276
8
22
my (@args, %present);
1277
8
20
@args = @{$_[0]};
8
34
1278
8
54
for (my $i=0; $i<=$#args; $i++) {
1279
88
170
foreach (keys %seen) {
1280
440
100
776
unless (defined $present{$args[$i]}) {
1281
163
100
398
$present{$args[$i]} = 1 if $seen{$_}{$args[$i]};
1282
}
1283
}
1284
88
100
250
$present{$args[$i]} = 0 if (! defined $present{$args[$i]});
1285
}
1286
8
89
return \%present;
1287
}
1288
1289
sub print_subset_chart {
1290
8
8
11604
my $class = shift;
1291
8
79
my %data = %$class;
1292
8
31
my @subset_array = @{$data{'xsubset'}};
8
38
1293
8
30
my $title = 'Subset';
1294
8
57
_chart_engine_multiple(\@subset_array, $title);
1295
}
1296
1297
sub print_equivalence_chart {
1298
8
8
25634
my $class = shift;
1299
8
81
my %data = %$class;
1300
8
30
my @equivalent_array = @{$data{'xequivalent'}};
8
40
1301
8
19
my $title = 'Equivalence';
1302
8
39
_chart_engine_multiple(\@equivalent_array, $title);
1303
}
1304
1305
sub get_bag {
1306
8
8
5812
return @{ get_bag_ref(shift) };
8
37
1307
}
1308
1309
sub get_bag_ref {
1310
16
16
6463
my $class = shift;
1311
16
118
my %data = %$class;
1312
16
140
return $data{'bag'};
1313
}
1314
1315
sub get_version {
1316
8
8
4842
return $List::Compare::VERSION;
1317
}
1318
1319
1;
1320
1321
################################################################################
1322
1323
package List::Compare::Multiple::Accelerated;
1324
34
34
305
use Carp;
34
79
34
2518
1325
34
2607
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
238
);
34
99
1335
34
34
232
use List::Compare::Base::_Auxiliary qw(:calculate);
34
60
34
6056
1336
34
27018
use List::Compare::Base::_Engine qw(
1337
_unique_all_engine
1338
_complement_all_engine
1339
34
34
18110
);
34
86
1340
1341
sub _init {
1342
22
22
45
my $self = shift;
1343
22
41
my $unsortflag = shift;
1344
22
97
my @listrefs = _argument_checker_0(@_);
1345
22
64
my %data = ();
1346
22
80
for (my $i=0; $i<=$#listrefs; $i++) {
1347
118
311
$data{$i} = $listrefs[$i];
1348
}
1349
22
100
96
$data{'unsort'} = $unsortflag ? 1 : 0;
1350
22
62
return \%data;
1351
}
1352
1353
sub get_union {
1354
8
8
4147
return @{ get_union_ref(shift) };
8
33
1355
}
1356
1357
sub get_union_ref {
1358
16
16
6589
my $class = shift;
1359
16
81
my %data = %$class;
1360
16
53
my $unsortflag = $data{'unsort'};
1361
16
64
my $aref = _prepare_listrefs(\%data);
1362
1363
16
57
my $unionref = _calculate_union_only($aref);
1364
16
100
45
my @union = $unsortflag ? keys %{$unionref} : sort(keys %{$unionref});
8
40
8
70
1365
16
118
return \@union;
1366
}
1367
1368
sub get_intersection {
1369
8
8
5841
return @{ get_intersection_ref(shift) };
8
38
1370
}
1371
1372
sub get_intersection_ref {
1373
16
16
5386
my $class = shift;
1374
16
76
my %data = %$class;
1375
16
40
my $unsortflag = $data{'unsort'};
1376
16
55
my $aref = _prepare_listrefs(\%data);
1377
16
77
my $intermediate_ref = _calculate_intermediate($aref);
1378
my @intersection =
1379
16
100
63
$unsortflag ? keys %{$intermediate_ref} : sort(keys %{$intermediate_ref});
8
30
8
31
1380
16
86
return \@intersection;
1381
}
1382
1383
sub get_nonintersection {
1384
8
8
14261
return @{ get_nonintersection_ref(shift) };
8
43
1385
}
1386
1387
sub get_nonintersection_ref {
1388
16
16
6755
my $class = shift;
1389
16
94
my %data = %$class;
1390
16
56
my $unsortflag = $data{'unsort'};
1391
16
68
my $aref = _prepare_listrefs(\%data);
1392
1393
16
59
my $unionref = _calculate_union_only($aref);
1394
16
79
my $intermediate_ref = _calculate_intermediate($aref);
1395
16
50
my (@nonintersection);
1396
16
31
foreach my $el (keys %{$unionref}) {
16
72
1397
160
100
370
push(@nonintersection, $el) unless exists $intermediate_ref->{$el};
1398
}
1399
16
100
189
return [ $unsortflag ? @nonintersection : sort(@nonintersection) ];
1400
}
1401
1402
sub get_shared {
1403
8
8
6027
return @{ get_shared_ref(shift) };
8
39
1404
}
1405
1406
sub get_shared_ref {
1407
16
16
5829
my $class = shift;
1408
16
76
my %data = %$class;
1409
16
41
my $unsortflag = $data{'unsort'};
1410
16
56
my $aref = _prepare_listrefs(\%data);
1411
16
52
my $aseenref = _calculate_array_seen_only($aref);
1412
16
50
my $intermediate = _calculate_sharedref($aseenref);
1413
16
100
55
my @shared = $unsortflag ? keys %{$intermediate} : sort(keys %{$intermediate});
8
36
8
102
1414
16
145
return \@shared;
1415
}
1416
1417
sub get_symmetric_difference {
1418
32
32
27367
return @{ get_symmetric_difference_ref(shift) };
32
98
1419
}
1420
1421
sub get_symmetric_difference_ref {
1422
64
64
11707
my $class = shift;
1423
64
347
my %data = %$class;
1424
64
156
my $unsortflag = $data{'unsort'};
1425
64
217
my $aref = _prepare_listrefs(\%data);
1426
64
199
my $unionref = _calculate_union_only($aref);
1427
1428
64
175
my $aseenref = _calculate_array_seen_only($aref);
1429
64
526
my $sharedref = _calculate_sharedref($aseenref);
1430
1431
64
106
my (@symmetric_difference);
1432
64
100
foreach my $el (keys %{$unionref}) {
64
212
1433
640
100
1242
push(@symmetric_difference, $el) unless exists $sharedref->{$el};
1434
}
1435
64
100
859
return [ $unsortflag ? @symmetric_difference : sort(@symmetric_difference) ];
1436
}
1437
1438
{
1439
34
34
300
no warnings 'once';
34
101
34
8959
1440
*get_symdiff = \&get_symmetric_difference;
1441
*get_symdiff_ref = \&get_symmetric_difference_ref;
1442
}
1443
1444
sub get_LorRonly {
1445
16
16
40916
my $class = shift;
1446
16
115
my $method = (caller(0))[3];
1447
16
188
$method =~ s/.*::(\w*)$/$1/;
1448
16
1669
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
951
get_symmetric_difference($class);
1450
}
1451
1452
sub get_LorRonly_ref {
1453
16
16
60231
my $class = shift;
1454
16
115
my $method = (caller(0))[3];
1455
16
156
$method =~ s/.*::(\w*)$/$1/;
1456
16
1578
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
887
get_symmetric_difference_ref($class);
1458
}
1459
1460
{
1461
34
34
276
no warnings 'once';
34
74
34
15093
1462
*get_AorBonly = \&get_LorRonly;
1463
*get_AorBonly_ref = \&get_LorRonly_ref;
1464
}
1465
1466
sub get_unique {
1467
36
36
15132
my $class = shift;
1468
36
202
my %data = %$class;
1469
36
100
146
my $index = defined $_[0] ? shift : 0;
1470
36
88
return @{ get_unique_ref($class, $index) };
36
87
1471
}
1472
1473
sub get_unique_ref {
1474
77
77
10275
my $class = shift;
1475
77
455
my %data = %$class;
1476
77
100
276
my $index = defined $_[0] ? shift : 0;
1477
77
274
my $aref = _prepare_listrefs(\%data);
1478
77
132
_index_message3($index, $#{$aref});
77
375
1479
1480
72
264
my $unique_all_ref = _unique_all_engine($aref);
1481
72
115
return ${$unique_all_ref}[$index];
72
619
1482
}
1483
1484
sub get_unique_all {
1485
8
8
21622
my $class = shift;
1486
8
59
my %data = %$class;
1487
8
42
my $aref = _prepare_listrefs(\%data);
1488
8
37
return _unique_all_engine($aref);
1489
}
1490
1491
sub get_Lonly {
1492
24
24
68304
my ($class, $index) = @_;
1493
24
189
my $method = (caller(0))[3];
1494
24
271
$method =~ s/.*::(\w*)$/$1/;
1495
24
2797
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
1867
get_unique($class, $index);
1497
}
1498
1499
sub get_Lonly_ref {
1500
24
24
137227
my ($class, $index) = @_;
1501
24
168
my $method = (caller(0))[3];
1502
24
225
$method =~ s/.*::(\w*)$/$1/;
1503
24
2536
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
1563
get_unique_ref($class, $index);
1505
}
1506
1507
{
1508
34
34
265
no warnings 'once';
34
64
34
17311
1509
*get_Aonly = \&get_Lonly;
1510
*get_Aonly_ref = \&get_Lonly_ref;
1511
}
1512
1513
sub get_complement {
1514
44
44
32449
my $class = shift;
1515
44
248
my %data = %$class;
1516
44
100
184
my $index = defined $_[0] ? shift : 0;
1517
44
76
return @{ get_complement_ref($class, $index) };
44
105
1518
}
1519
1520
sub get_complement_ref {
1521
93
93
14380
my $class = shift;
1522
93
426
my %data = %$class;
1523
93
100
278
my $index = defined $_[0] ? shift : 0;
1524
93
177
my $unsortflag = $data{'unsort'};
1525
93
350
my $aref = _prepare_listrefs(\%data);
1526
93
170
_index_message3($index, $#{$aref});
93
441
1527
1528
88
328
my $complement_all_ref = _complement_all_engine($aref, $unsortflag );
1529
88
163
return ${$complement_all_ref}[$index];
88
840
1530
}
1531
1532
sub get_complement_all {
1533
8
8
19907
my $class = shift;
1534
8
63
my %data = %$class;
1535
8
51
my $aref = _prepare_listrefs(\%data);
1536
8
67
return _complement_all_engine($aref);
1537
}
1538
1539
sub get_Ronly {
1540
28
28
72258
my ($class, $index) = @_;
1541
28
201
my $method = (caller(0))[3];
1542
28
248
$method =~ s/.*::(\w*)$/$1/;
1543
28
2740
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
1764
&get_complement($class, $index);
1545
}
1546
1547
sub get_Ronly_ref {
1548
28
28
103362
my ($class, $index) = @_;
1549
28
237
my $method = (caller(0))[3];
1550
28
256
$method =~ s/.*::(\w*)$/$1/;
1551
28
2619
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
1675
&get_complement_ref($class, $index);
1553
}
1554
1555
{
1556
34
34
270
no warnings 'once';
34
69
34
3662
1557
*get_Bonly = \&get_Ronly;
1558
*get_Bonly_ref = \&get_Ronly_ref;
1559
}
1560
1561
sub is_LsubsetR {
1562
48
48
20663
my $class = shift;
1563
48
240
my %data = %$class;
1564
48
240
my $subset_status = _subset_engine_multaccel(\%data, @_);
1565
40
130
return $subset_status;
1566
}
1567
1568
34
34
248
{ no warnings 'once'; *is_AsubsetB = \&is_LsubsetR; }
34
74
34
5696
1569
1570
sub is_RsubsetL {
1571
16
16
39378
my $class = shift;
1572
16
103
my %data = %$class;
1573
1574
16
121
my $method = (caller(0))[3];
1575
16
143
$method =~ s/.*::(\w*)$/$1/;
1576
16
1634
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
997
@_ = (1,0);
1578
1579
16
84
my $subset_status = _subset_engine_multaccel(\%data, @_);
1580
16
126
return $subset_status;
1581
}
1582
1583
34
34
243
{ no warnings 'once'; *is_BsubsetA = \&is_RsubsetL; }
34
66
34
4651
1584
1585
sub is_LequivalentR {
1586
33
33
27327
my $class = shift;
1587
33
178
my %data = %$class;
1588
33
124
my $aref = _prepare_listrefs(\%data);
1589
33
68
my ($index_left, $index_right) = _index_message4($#{$aref}, @_);
33
126
1590
1591
24
122
my $xequivalentref = _equivalent_subengine($aref);
1592
24
41
return ${$xequivalentref}[$index_left][$index_right];
24
144
1593
}
1594
1595
34
34
266
{ no warnings 'once'; *is_LeqvlntR = \&is_LequivalentR; }
34
122
34
51662
1596
1597
sub is_LdisjointR {
1598
29
29
9147
my $class = shift;
1599
29
154
my %data = %$class;
1600
29
112
my $aref = _prepare_listrefs(\%data);
1601
29
93
my ($index_left, $index_right) = _index_message4($#{$aref}, @_);
29
121
1602
24
123
my $aseenref = _calculate_array_seen_only(
1603
[ $aref->[$index_left], $aref->[$index_right] ]
1604
);
1605
24
58
my $disjoint_status = 1;
1606
24
39
OUTER: for my $k (keys %{$aseenref->[0]}) {
24
82
1607
51
100
120
if ($aseenref->[1]->{$k}) {
1608
16
29
$disjoint_status = 0;
1609
16
47
last OUTER;
1610
}
1611
}
1612
24
147
return $disjoint_status;
1613
}
1614
1615
sub is_member_which {
1616
92
92
28959
return @{ is_member_which_ref(@_) };
92
181
1617
}
1618
1619
sub is_member_which_ref {
1620
185
185
23921
my $class = shift;
1621
185
100
100
1583
croak "Method call requires exactly 1 argument (no references): $!"
1622
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
1623
176
254
my %data = %{$class};
176
614
1624
176
482
my $aref = _prepare_listrefs(\%data);
1625
176
417
my $seenref = _calculate_seen_only($aref);
1626
176
320
my ($arg, @found);
1627
176
271
$arg = shift;
1628
176
267
foreach (sort keys %{$seenref}) {
176
670
1629
880
100
1159
push @found, $_ if (exists ${$seenref}{$_}{$arg});
880
2014
1630
}
1631
176
1079
return \@found;
1632
}
1633
1634
sub are_members_which {
1635
13
13
23006
my $class = shift;
1636
13
100
100
493
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
43
my $aref = _prepare_listrefs(\%data);
1640
8
37
my $seenref = _calculate_seen_only($aref);
1641
8
28
my (@args, %found);
1642
8
31
@args = @{$_[0]};
8
39
1643
8
68
for (my $i=0; $i<=$#args; $i++) {
1644
88
124
my (@not_found);
1645
88
195
foreach (sort keys %{$seenref}) {
88
255
1646
440
544
exists ${${$seenref}{$_}}{$args[$i]}
440
918
1647
440
100
545
? push @{$found{$args[$i]}}, $_
216
492
1648
: push @not_found, $_;
1649
}
1650
88
100
174
$found{$args[$i]} = [] if (@not_found == keys %{$seenref});
88
287
1651
}
1652
8
71
return \%found;
1653
}
1654
1655
sub is_member_any {
1656
93
93
15849
my $class = shift;
1657
93
100
100
855
croak "Method call requires exactly 1 argument (no references): $!"
1658
unless (@_ == 1 and ref($_[0]) ne 'ARRAY');
1659
88
348
my %data = %$class;
1660
88
240
my $aref = _prepare_listrefs(\%data);
1661
88
210
my $seenref = _calculate_seen_only($aref);
1662
88
136
my ($arg, $k);
1663
88
165
$arg = shift;
1664
88
111
while ( $k = each %{$seenref} ) {
193
458
1665
185
100
273
return 1 if (defined ${$seenref}{$k}{$arg});
185
709
1666
}
1667
8
54
return 0;
1668
}
1669
1670
sub are_members_any {
1671
13
13
7315
my $class = shift;
1672
13
100
100
503
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
52
my %data = %$class;
1675
8
52
my $aref = _prepare_listrefs(\%data);
1676
8
34
my $seenref = _calculate_seen_only($aref);
1677
8
24
my (@args, %present);
1678
8
20
@args = @{$_[0]};
8
46
1679
8
103
for (my $i=0; $i<=$#args; $i++) {
1680
88
121
foreach (keys %{$seenref}) {
88
200
1681
440
100
871
unless (defined $present{$args[$i]}) {
1682
181
100
217
$present{$args[$i]} = 1 if ${$seenref}{$_}{$args[$i]};
181
450
1683
}
1684
}
1685
88
100
245
$present{$args[$i]} = 0 if (! defined $present{$args[$i]});
1686
}
1687
8
90
return \%present;
1688
}
1689
1690
sub print_subset_chart {
1691
8
8
11946
my $class = shift;
1692
8
57
my %data = %$class;
1693
8
55
my $aref = _prepare_listrefs(\%data);
1694
8
50
my $xsubsetref = _subset_subengine($aref);
1695
8
27
my $title = 'Subset';
1696
8
50
_chart_engine_multiple($xsubsetref, $title);
1697
}
1698
1699
sub print_equivalence_chart {
1700
8
8
27808
my $class = shift;
1701
8
57
my %data = %$class;
1702
8
47
my $aref = _prepare_listrefs(\%data);
1703
8
47
my $xequivalentref = _equivalent_subengine($aref);
1704
8
28
my $title = 'Equivalence';
1705
8
35
_chart_engine_multiple($xequivalentref, $title);
1706
}
1707
1708
sub get_bag {
1709
8
8
6728
return @{ get_bag_ref(shift) };
8
68
1710
}
1711
1712
sub get_bag_ref {
1713
16
16
7545
my $class = shift;
1714
16
101
my %data = %$class;
1715
16
45
my $unsortflag = $data{'unsort'};
1716
16
106
my $aref = _prepare_listrefs(\%data);
1717
16
36
my (@bag);
1718
16
34
my @listrefs = @{$aref};
16
62
1719
16
100
66
if (ref($listrefs[0]) eq 'ARRAY') {
1720
8
22
foreach my $lref (@listrefs) {
1721
40
67
foreach my $el (@{$lref}) {
40
72
1722
256
421
push(@bag, $el);
1723
}
1724
}
1725
} else {
1726
8
30
foreach my $lref (@listrefs) {
1727
40
57
foreach my $key (keys %{$lref}) {
40
87
1728
216
302
for (my $j=1; $j <= ${$lref}{$key}; $j++) {
472
874
1729
256
447
push(@bag, $key);
1730
}
1731
}
1732
}
1733
}
1734
16
100
158
@bag = sort(@bag) unless $unsortflag;
1735
16
160
return \@bag;
1736
}
1737
1738
sub get_version {
1739
8
8
5206
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.54 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