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