File Coverage

blib/lib/Tie/FlatFile/Array.pm
Criterion Covered Total %
statement 91 116 78.4
branch 6 14 42.8
condition n/a
subroutine 20 24 83.3
pod n/a
total 117 154 75.9


line stmt bran cond sub pod time code
1              
2 1     1   23369 use strict;
  1         2  
  1         33  
3 1     1   5 use warnings;
  1         2  
  1         40  
4              
5             package Tie::FlatFile::Array;
6 1     1   4 use base 'Class::Accessor';
  1         7  
  1         1353  
7 1     1   3208 use Carp qw(croak);
  1         2  
  1         91  
8 1     1   5 use Fcntl;
  1         2  
  1         587  
9 1     1   1012 use POSIX qw(:stdio_h ceil);
  1         7891  
  1         6  
10 1     1   2347 use FileHandle;
  1         12070  
  1         6  
11 1     1   1602 use English qw(-no_match_vars);
  1         6583  
  1         8  
12 1     1   1594 use File::Spec::Functions qw(catfile splitpath);
  1         911  
  1         139  
13              
14             my @fields;
15              
16             BEGIN {
17 1     1   3 our $VERSION = "0.05_01";
18 1         59 $VERSION = eval $VERSION;
19 1         6 @fields = qw(filename flags mode packformat handle
20             reclen nulls nulla);
21 1         14 __PACKAGE__->mk_accessors(@fields);
22 1         560 *fh = \&handle;
23             # require Tie::FlatFile::ArrayHelper;
24             }
25              
26             sub TIEARRAY {
27 8     8   15 my $class = shift;
28 8         23 my $self = bless({}, $class);
29 8         16 my ($filename, $flags, $mode, $opts) = @_;
30 8         11 my ($packformat);
31 8         14 local $Carp::CarpLevel = 1; # Set the stack frame for croak().
32              
33 8 50       22 if ('HASH' ne ref($opts)) {
34 0         0 croak('Options hash missing');
35             } else {
36 8         15 $packformat = $opts->{packformat};
37             }
38              
39             # Check for missing parameters.
40 8         20 foreach my $nm (qw(filename flags mode packformat)) {
41 32         1789 my $value = eval "\$$nm";
42 32 50       111 unless (defined ($value)) {
43 0         0 croak("Missing $nm");
44             }
45 32         112 $self->$nm($value);
46             }
47              
48             # Open the file and save the file handle.
49 8         126 my $fh = new FileHandle $filename, $flags;
50 8         853 $self->handle($fh);
51              
52             # Store the record length;
53 8         120 my $len = $self->reclen(length(pack $packformat, (1) x 30));
54              
55             {
56 1     1   7 no warnings 'uninitialized';
  1         1  
  1         1007  
  8         78  
57 8         46 $self->nulls(pack $packformat, (undef) x 30);
58 8         100 $self->nulla([(undef) x 30]);
59             }
60              
61 8         98 $self;
62             }
63              
64             sub UNTIE {
65 8     8   487 my $self = shift;
66 8 50       19 return unless $self->handle;
67 8         88 close($self->handle);
68             }
69              
70             sub FETCH {
71 8     8   51 my ($self, $index) = @_;
72 8 50       21 return undef if $index < 0;
73              
74 8         22 my $len = $self->reclen;
75 8         77 my $fh = $self->fh;
76 8         70 local $Carp::CarpLevel = 1; # Set the stack frame for croak().
77              
78 8         30 local $RS = \$len; # Set the record length.
79 8         83 seek($fh, $index * $len, SEEK_SET);
80 8         68 my $data = <$fh>; # Get a record.
81 8 100       29 return undef unless $data;
82              
83             # Unpack and return the data as an array reference.
84 7         20 [ unpack $self->packformat, $data ];
85             }
86              
87             sub STORE {
88 28     28   221 my ($self, $index, $value) = @_;
89 28         65 my $len = $self->reclen;
90 28         256 my $fh = $self->fh;
91              
92 28         498 seek($fh, $index * $len, SEEK_SET);
93 28         84 print $fh (pack $self->packformat, @$value);
94             }
95              
96             sub FETCHSIZE {
97 9     9   20 my $self = shift;
98 9         23 my $pos = tell($self->fh);
99              
100             # Go to the end of the file and find out the
101             # size in bytes [using tell()] and divide that
102             # by the size of a record.
103 9         88 seek($self->fh, 0, SEEK_END);
104 9         182 my $size = tell($self->fh) / $self->reclen;
105 9         157 $size = ceil($size);
106              
107             # Go back to the original position in the file.
108 9         25 seek($self->fh, $pos, SEEK_SET);
109 9         121 $size;
110             }
111              
112              
113 2     2   98 sub EXTEND {
114             }
115              
116              
117             sub EXISTS {
118 0     0   0 my ($self, $index) = @_;
119 0 0       0 $index >= 0 && $index < $self->FETCHSIZE;
120             }
121              
122             sub DELETE {
123 0     0   0 my ($self, $index) = @_;
124 0         0 $self->STORE($index, $self->nulla);
125             }
126              
127             sub CLEAR {
128 2     2   17 my $self = shift;
129 2         7 truncate($self->fh, 0);
130             }
131              
132             sub PUSH {
133 5     5   87 my $self = shift;
134 5         12 my $size = $self->FETCHSIZE;
135 5         26 $self->STORE($size++, +shift) while (@_);
136             }
137              
138             sub POP {
139 0     0   0 my $self = shift;
140 0         0 my $size = $self->FETCHSIZE;
141 0         0 my $data = $self->FETCH($size-1);
142 0         0 truncate($self->fh, ($size-1) * $self->reclen);
143 0         0 $data;
144             }
145              
146             sub SHIFT {
147 0     0   0 my $self = shift;
148 0         0 my $size = $self->FETCHSIZE;
149 0 0       0 return undef unless $size;
150              
151 0         0 my $data = $self->FETCH(0);
152 0         0 my $reclen = $self->reclen;
153 0         0 my $fh = $self->fh;
154 0         0 local $RS = \$reclen;
155              
156 0         0 foreach my $n (0..$size-2) {
157 0         0 seek($fh, ($n+1) * $reclen, SEEK_SET);
158 0         0 my $temp = <$fh>;
159 0         0 seek($fh, -2*$reclen, SEEK_CUR);
160 0         0 print $fh $temp;
161             }
162              
163 0         0 truncate($fh, ($size-1)*$reclen );
164 0         0 $data;
165             }
166              
167             sub UNSHIFT {
168 1     1   9 my $self = shift;
169              
170 1         5 for (my $n = $self->FETCHSIZE-1; $n >= 0; --$n) {
171 5         63 my $ele = $self->FETCH($n);
172 5         90 $self->STORE($n + @_, $ele);
173             }
174              
175 1         17 foreach my $n (0..$#_) {
176 3         31 $self->STORE($n, $_[$n]);
177             }
178 1         15 $self->FETCHSIZE;
179             }
180              
181              
182             1;
183