File Coverage

blib/lib/File/LinearRaid.pm
Criterion Covered Total %
statement 97 107 90.6
branch 29 42 69.0
condition 6 7 85.7
subroutine 15 18 83.3
pod 0 1 0.0
total 147 175 84.0


line stmt bran cond sub pod time code
1             package File::LinearRaid;
2              
3 1     1   441 use strict;
  1         2  
  1         22  
4 1     1   4 use warnings;
  1         2  
  1         23  
5 1     1   15 use Symbol;
  1         4  
  1         58  
6 1     1   6 use Carp;
  1         1  
  1         44  
7 1     1   5 use vars '$VERSION';
  1         1  
  1         868  
8              
9             $VERSION = '0.11_1';
10              
11             sub new {
12 3     3 0 2640 my $pkg = shift;
13            
14 3         10 my $sym = gensym;
15 3         60 tie *$sym, $pkg, @_;
16              
17 3         9 return bless $sym, $pkg;
18             }
19              
20             sub TIEHANDLE {
21 3     3   7 my $pkg = shift;
22 3         7 my $mode = shift;
23            
24 3         8 my @files;
25             my @sizes;
26 3         0 my @handles;
27 3         7 my $length = 0;
28            
29 3         14 while (my ($file, $size) = splice @_, 0, 2) {
30 7 50       153 open my $fh, $mode, $file or croak "Couldn't open $file: $!\n";
31            
32 7         26 push @handles, $fh;
33 7         14 push @files, $file;
34 7         12 push @sizes, $size;
35 7         28 $length += $size;
36             }
37            
38             bless {
39 3         23 pos => 0,
40             files => \@files,
41             sizes => \@sizes,
42             handles => \@handles,
43             length => $length,
44             last_file => $#files
45             }, $pkg;
46             }
47              
48             sub READ {
49 19     19   59 my ($self, undef, $length, $offset) = @_;
50            
51 19   100     63 $offset ||= 0;
52            
53 19 100       38 if ($self->EOF) {
54 5         10 substr($_[1], $offset) = "";
55 5         21 return 0;
56             }
57            
58 14         24 my $pos = $self->{pos};
59              
60 14         20 my $f = 0;
61 14         33 while ($pos >= $self->{sizes}[$f]) {
62 9         14 $pos -= $self->{sizes}[$f];
63 9         20 $f++;
64             }
65            
66 14         23 my $b;
67            
68             my $this_read = ($pos + $length > $self->{sizes}[$f])
69 14 100       31 ? $self->{sizes}[$f] - $pos
70             : $length;
71            
72 14 50       64 seek $self->{handles}[$f], $pos, 0
73             or croak "Couldn't seek $self->{files}[$f]";
74            
75 14         88 $b = read $self->{handles}[$f], $_[1], $this_read, $offset;
76              
77 14 50       38 defined $b or croak "Error reading from $self->{files}[$f]: $!";
78              
79 14         21 $self->{pos} += $this_read;
80            
81 14 100       28 if ( $b < $this_read ) {
82             # pad out rest of chunk with nulls
83 2         6 substr($_[1], $offset + $b) = "\x0" x ($this_read - $b);
84             }
85              
86 14 100       29 if ($this_read == $length) {
87 5         14 return $length;
88             } else {
89 9         30 return $this_read + $self->READ($_[1], $length - $this_read, $offset + $this_read);
90             }
91             }
92              
93             sub READLINE {
94 6     6   1215 my $self = shift;
95 6         11 my $oldpos = $self->{pos};
96              
97 6 100       12 return undef if $self->EOF;
98            
99 5         10 my $buf = "";
100            
101 5 100       13 if (not defined $/) {
    50          
102 2         5 $self->READ($buf, $self->{length} - $oldpos);
103             } elsif (ref $/) {
104 0         0 $self->READ($buf, ${$/});
  0         0  
105             } else {
106            
107 3   66     12 while (index($buf, $/) == -1 and not $self->EOF) {
108 3         9 $self->READ($buf, 1024, length $buf);
109             }
110            
111 3 50       10 if (index($buf, $/) != -1) {
112 3         7 substr($buf, index($buf, $/) + length($/)) = "";
113 3         6 $self->{pos} = $oldpos + length $buf;
114             }
115             }
116            
117 5         19 return $buf;
118            
119             }
120              
121             sub GETC {
122 0     0   0 my $c;
123 0         0 $_[0]->READ($c, 1);
124 0         0 return $c;
125             }
126              
127              
128              
129             sub WRITE {
130 3     3   6 my ($self, undef, $length, $offset) = @_;
131            
132 3   100     13 $offset ||= 0;
133            
134 3 50       8 if ($self->EOF) {
135 0         0 return 0;
136             }
137            
138 3         7 my $pos = $self->{pos};
139              
140 3         4 my $f = 0;
141 3         9 while ($pos >= $self->{sizes}[$f]) {
142 1         3 $pos -= $self->{sizes}[$f];
143 1         4 $f++;
144             }
145            
146             my $this_write = ($pos + $length > $self->{sizes}[$f])
147 3 100       10 ? $self->{sizes}[$f] - $pos
148             : $length;
149            
150 3 50       30 seek $self->{handles}[$f], $pos, 0
151             or croak "Couldn't seek $self->{files}[$f]";
152            
153 3 50       4 print { $self->{handles}[$f] } substr($_[1], $offset, $this_write)
  3         20  
154             or return 0;
155              
156 3         7 $self->{pos} += $this_write;
157              
158 3 100       8 if ($this_write == $length) {
159 2         7 return 1;
160             } else {
161 1         9 return $self->WRITE($_[1], $length - $this_write, $offset + $this_write);
162             }
163             }
164              
165             sub PRINT {
166 2     2   12 my $self = shift;
167 2 50       6 my $buf = join +(defined $, ? $, : "") => @_;
168 2         6 $self->WRITE($buf, length($buf), 0);
169             }
170              
171             sub PRINTF {
172 0     0   0 my $self = shift;
173 0         0 my $fmt = shift;
174 0         0 $self->PRINT( sprintf $fmt, @_ );
175             }
176              
177              
178              
179             sub SEEK {
180 11     11   2854 my ($self, $offset, $whence) = @_;
181            
182 11         19 my $pos = $self->{pos};
183            
184 11 50       27 $whence == 0 and $pos = $offset;
185 11 50       23 $whence == 1 and $pos += $offset;
186 11 50       21 $whence == 2 and $pos = $self->{size} + $offset;
187              
188 11 50       24 return 0 if $pos < 0;
189 11         19 $self->{pos} = $pos;
190 11         32 return 1;
191             }
192              
193             sub TELL {
194 13     13   6670 $_[0]->{pos};
195             }
196              
197             sub EOF {
198 32     32   48 my $self = shift;
199 32         106 return $self->{pos} == $self->{length};
200             }
201              
202             sub CLOSE {
203 1     1   394 close $_ for @{ $_[0]->{handles} };
  1         12  
204 1         29 $_[0] = undef;
205             }
206              
207             sub OPEN {
208 0     0     croak "OPEN Unimplemented";
209             }
210             1;
211              
212             __END__