File Coverage

blib/lib/Math/Prime/Util/PrimeArray.pm
Criterion Covered Total %
statement 79 85 92.9
branch 20 30 66.6
condition 15 15 100.0
subroutine 15 20 75.0
pod n/a
total 129 150 86.0


line stmt bran cond sub pod time code
1             package Math::Prime::Util::PrimeArray;
2 2     2   48034 use strict;
  2         17  
  2         67  
3 2     2   11 use warnings;
  2         6  
  2         86  
4              
5             BEGIN {
6 2     2   6 $Math::Prime::Util::PrimeArray::AUTHORITY = 'cpan:DANAJ';
7 2         54 $Math::Prime::Util::PrimeArray::VERSION = '0.69';
8             }
9              
10             # parent is cleaner, and in the Perl 5.10.1 / 5.12.0 core, but not earlier.
11             # use parent qw( Exporter );
12 2     2   13 use base qw( Exporter );
  2         4  
  2         649  
13             our @EXPORT_OK = qw(@primes @prime @pr @p $probj);
14             our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
15              
16             # It would be nice to do this dynamically.
17             our(@primes, @prime, @pr, @p, $probj);
18             sub import {
19 2 50   2   13 tie @primes, __PACKAGE__ if grep { $_ eq '@primes' } @_;
  2         10  
20 2 50       3 tie @prime , __PACKAGE__ if grep { $_ eq '@prime' } @_;
  2         6  
21 2 50       4 tie @pr , __PACKAGE__ if grep { $_ eq '@pr' } @_;
  2         6  
22 2 50       3 tie @p , __PACKAGE__ if grep { $_ eq '@p' } @_;
  2         5  
23 2 50       3 $probj = __PACKAGE__->TIEARRAY if grep { $_ eq '$probj' } @_;
  2         5  
24 2         1727 goto &Exporter::import;
25             }
26              
27 2     2   766 use Math::Prime::Util qw/nth_prime nth_prime_upper nth_prime_lower primes prime_precalc next_prime prev_prime/;
  2         5  
  2         8  
28 2     2   511 use Tie::Array;
  2         1748  
  2         50  
29 2     2   11 use Carp qw/carp croak confess/;
  2         3  
  2         83  
30              
31 2     2   11 use constant SEGMENT_SIZE => 50_000;
  2         3  
  2         109  
32 2     2   12 use constant ALLOW_SKIP => 3_000; # Sieve if skipping up to this
  2         5  
  2         1180  
33              
34             sub TIEARRAY {
35 4     4   896 my $class = shift;
36 4 50       12 if (@_) {
37 0         0 croak "usage: tie ARRAY, '" . __PACKAGE__ . "";
38             }
39 4         21 return bless {
40             # used to keep track of shift
41             SHIFTINDEX => 0,
42             # Remove all extra prime memory when we go out of scope
43             MEMFREE => Math::Prime::Util::MemFree->new,
44             # A chunk of primes
45             PRIMES => [2, 3, 5, 7, 11, 13, 17],
46             # What's the index of the first one?
47             BEG_INDEX => 0,
48             # What's the index of the last one?
49             END_INDEX => 6,
50             # positive = forward, negative = backward, 0 = random
51             ACCESS_TYPE => 0,
52             }, $class;
53             }
54 0     0   0 sub STORE { carp "You cannot write to the prime array"; }
55 0     0   0 sub DELETE { carp "You cannot write to the prime array"; }
56 0     0   0 sub STORESIZE { carp "You cannot write to the prime array"; }
57 0     0   0 sub EXISTS { 1 }
58             #sub EXTEND { my $self = shift; my $count = shift; prime_precalc($count); }
59 0     0   0 sub EXTEND { 1 }
60 2     2   5 sub FETCHSIZE { 0x7FFF_FFFF } # Even on 64-bit
61             # Simple FETCH:
62             # sub FETCH { return nth_prime($_[1]+1); }
63              
64             sub FETCH {
65 2067     2067   20970 my ($self, $index) = @_;
66 2067 50       3267 $index = 0xFFFFFFFF + $index + 1 if $index < 0;
67 2067         2668 $index += $self->{SHIFTINDEX}; # take into account any shifts
68 2067         2597 my $begidx = $self->{BEG_INDEX};
69 2067         2450 my $endidx = $self->{END_INDEX};
70              
71 2067 100 100     5109 if ( $index < $begidx || $index > $endidx ) {
72              
73 52 100 100     206 if ($index > $endidx && $index < $endidx + ALLOW_SKIP) { # Forward iteration
    100 100        
74              
75 21         35 $self->{ACCESS_TYPE}++;
76 21 100 100     57 if ($self->{ACCESS_TYPE} > 2 || $index > $endidx+1) {
77 14         386 my $end_prime = nth_prime_upper($index + SEGMENT_SIZE);
78 14         61 $self->{PRIMES} = primes( $self->{PRIMES}->[-1]+1, $end_prime );
79 14         25 $begidx = $endidx+1;
80             } else {
81 7         13 push @{$self->{PRIMES}}, next_prime($self->{PRIMES}->[-1]);
  7         31  
82             }
83              
84             } elsif ($index < $begidx && $index > $begidx - ALLOW_SKIP) { # Bk iteration
85              
86 24         43 $self->{ACCESS_TYPE}--;
87 24 100 100     77 if ($self->{ACCESS_TYPE} < -2 || $index < $begidx-1) {
88 14 50       31 my $beg_prime = $index <= SEGMENT_SIZE
89             ? 2 : nth_prime_lower($index - SEGMENT_SIZE);
90 14         52 $self->{PRIMES} = primes($beg_prime, $self->{PRIMES}->[0]-1);
91 14         50 $begidx -= scalar @{ $self->{PRIMES} };
  14         46  
92             } else {
93 10         15 $begidx--;
94 10         13 unshift @{$self->{PRIMES}}, prev_prime($self->{PRIMES}->[0]);
  10         1398  
95             }
96              
97             } else { # Random access
98              
99 7         23 $self->{ACCESS_TYPE} = int($self->{ACCESS_TYPE} / 2);
100             # Alternately we could get a small window, but that will be quite
101             # a bit slower if true random access.
102 7         15 $begidx = $index;
103 7         728 $self->{PRIMES} = [nth_prime($begidx+1)];
104              
105             }
106 52         105 $self->{BEG_INDEX} = $begidx;
107 52         68 $self->{END_INDEX} = $begidx + scalar @{$self->{PRIMES}} - 1;
  52         94  
108             }
109 2067         5187 return $self->{PRIMES}->[ $index - $begidx ];
110             }
111              
112             # Fake out shift and unshift
113             sub SHIFT {
114 5     5   13 my $self = shift;
115 5         10 my $head = $self->FETCH(0);
116 5         8 $self->{SHIFTINDEX}++;
117 5         20 $head;
118             }
119             sub UNSHIFT {
120 2     2   408 my ($self, $shiftamount) = @_;
121 2 50       6 $shiftamount = 1 unless defined $shiftamount;
122             $self->{SHIFTINDEX} = ($shiftamount >= $self->{SHIFTINDEX})
123             ? 0
124 2 50       6 : $self->{SHIFTINDEX} - $shiftamount;
125 2         7 $self->FETCHSIZE;
126             }
127             # CLEAR this
128             # PUSH this, LIST
129             # POP this
130             # SPLICE this, offset, len, LIST
131             # DESTROY this
132             # UNTIE this
133              
134             1;
135              
136             __END__