Commit | Line | Data |
d426259c |
1 | package DBM::Deep::Storage::File; |
460b1067 |
2 | |
2120a181 |
3 | use 5.006_000; |
460b1067 |
4 | |
5 | use strict; |
065b45be |
6 | use warnings FATAL => 'all'; |
460b1067 |
7 | |
86867f3a |
8 | use Fcntl qw( :DEFAULT :flock :seek ); |
460b1067 |
9 | |
40963fba |
10 | use constant DEBUG => 0; |
695c88b1 |
11 | |
2c70efe1 |
12 | use base 'DBM::Deep::Storage'; |
13 | |
76855018 |
14 | =head1 NAME |
15 | |
d426259c |
16 | DBM::Deep::Storage::File |
76855018 |
17 | |
18 | =head1 PURPOSE |
19 | |
20 | This is an internal-use-only object for L<DBM::Deep/>. It mediates the low-level |
21 | interaction with the storage mechanism. |
22 | |
23 | Currently, the only storage mechanism supported is the file system. |
24 | |
25 | =head1 OVERVIEW |
26 | |
d426259c |
27 | This class provides an abstraction to the storage mechanism so that the Engine |
28 | (the only class that uses this class) doesn't have to worry about that. |
76855018 |
29 | |
30 | =head1 METHODS |
31 | |
32 | =head2 new( \%args ) |
33 | |
34 | =cut |
35 | |
460b1067 |
36 | sub new { |
37 | my $class = shift; |
38 | my ($args) = @_; |
39 | |
40 | my $self = bless { |
359a01ac |
41 | autobless => 1, |
2120a181 |
42 | autoflush => 1, |
460b1067 |
43 | end => 0, |
44 | fh => undef, |
45 | file => undef, |
46 | file_offset => 0, |
2120a181 |
47 | locking => 1, |
460b1067 |
48 | locked => 0, |
2120a181 |
49 | #XXX Migrate this to the engine, where it really belongs. |
460b1067 |
50 | filter_store_key => undef, |
51 | filter_store_value => undef, |
52 | filter_fetch_key => undef, |
53 | filter_fetch_value => undef, |
54 | }, $class; |
55 | |
56 | # Grab the parameters we want to use |
57 | foreach my $param ( keys %$self ) { |
58 | next unless exists $args->{$param}; |
59 | $self->{$param} = $args->{$param}; |
60 | } |
61 | |
62 | if ( $self->{fh} && !$self->{file_offset} ) { |
63 | $self->{file_offset} = tell( $self->{fh} ); |
64 | } |
65 | |
66 | $self->open unless $self->{fh}; |
67 | |
68 | return $self; |
69 | } |
70 | |
76855018 |
71 | =head2 open() |
72 | |
73 | This method opens the filehandle for the filename in C< file >. |
74 | |
75 | There is no return value. |
76 | |
77 | =cut |
78 | |
460b1067 |
79 | sub open { |
80 | my $self = shift; |
81 | |
633df1fd |
82 | # Adding O_BINARY should remove the need for the binmode below. However, |
460b1067 |
83 | # I'm not going to remove it because I don't have the Win32 chops to be |
84 | # absolutely certain everything will be ok. |
e9b0b5f0 |
85 | my $flags = O_CREAT | O_BINARY; |
86 | |
87 | if ( !-e $self->{file} || -w _ ) { |
88 | $flags |= O_RDWR; |
89 | } |
90 | else { |
91 | $flags |= O_RDONLY; |
92 | } |
460b1067 |
93 | |
94 | my $fh; |
95 | sysopen( $fh, $self->{file}, $flags ) |
96 | or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n"; |
97 | $self->{fh} = $fh; |
98 | |
99 | # Even though we use O_BINARY, better be safe than sorry. |
100 | binmode $fh; |
101 | |
102 | if ($self->{autoflush}) { |
103 | my $old = select $fh; |
104 | $|=1; |
105 | select $old; |
106 | } |
107 | |
108 | return 1; |
109 | } |
110 | |
76855018 |
111 | =head2 close() |
112 | |
113 | If the filehandle is opened, this will close it. |
114 | |
115 | There is no return value. |
116 | |
117 | =cut |
118 | |
460b1067 |
119 | sub close { |
120 | my $self = shift; |
121 | |
122 | if ( $self->{fh} ) { |
123 | close $self->{fh}; |
124 | $self->{fh} = undef; |
125 | } |
126 | |
127 | return 1; |
128 | } |
129 | |
76855018 |
130 | =head2 size() |
131 | |
132 | This will return the size of the DB. If file_offset is set, this will take that into account. |
133 | |
134 | =cut |
135 | |
00d9bd0b |
136 | sub size { |
137 | my $self = shift; |
138 | |
139 | return 0 unless $self->{fh}; |
f3c5ac06 |
140 | return( (-s $self->{fh}) - $self->{file_offset} ); |
00d9bd0b |
141 | } |
142 | |
76855018 |
143 | =head2 set_inode() |
144 | |
145 | This will set the inode value of the underlying file object. |
146 | |
d426259c |
147 | This is only needed to handle some obscure Win32 bugs. It reqlly shouldn't be |
148 | needed outside this object. |
76855018 |
149 | |
150 | There is no return value. |
151 | |
152 | =cut |
153 | |
7dcefff3 |
154 | sub set_inode { |
155 | my $self = shift; |
156 | |
2120a181 |
157 | unless ( defined $self->{inode} ) { |
7dcefff3 |
158 | my @stats = stat($self->{fh}); |
159 | $self->{inode} = $stats[1]; |
160 | $self->{end} = $stats[7]; |
161 | } |
162 | |
163 | return 1; |
164 | } |
165 | |
76855018 |
166 | =head2 print_at( $offset, @data ) |
167 | |
168 | This takes an optional offset and some data to print. |
169 | |
d426259c |
170 | C< $offset >, if defined, will be used to seek into the file. If file_offset is |
171 | set, it will be used as the zero location. If it is undefined, no seeking will |
172 | occur. Then, C< @data > will be printed to the current location. |
76855018 |
173 | |
174 | There is no return value. |
175 | |
176 | =cut |
177 | |
019404df |
178 | sub print_at { |
179 | my $self = shift; |
180 | my $loc = shift; |
181 | |
182 | local ($/,$\); |
183 | |
184 | my $fh = $self->{fh}; |
7dcefff3 |
185 | if ( defined $loc ) { |
186 | seek( $fh, $loc + $self->{file_offset}, SEEK_SET ); |
187 | } |
188 | |
695c88b1 |
189 | if ( DEBUG ) { |
190 | my $caller = join ':', (caller)[0,2]; |
191 | my $len = length( join '', @_ ); |
192 | warn "($caller) print_at( " . (defined $loc ? $loc : '<undef>') . ", $len )\n"; |
193 | } |
194 | |
45f047f8 |
195 | print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n"; |
019404df |
196 | |
197 | return 1; |
198 | } |
199 | |
76855018 |
200 | =head2 read_at( $offset, $length ) |
201 | |
202 | This takes an optional offset and a length. |
203 | |
d426259c |
204 | C< $offset >, if defined, will be used to seek into the file. If file_offset is |
205 | set, it will be used as the zero location. If it is undefined, no seeking will |
206 | occur. Then, C< $length > bytes will be read from the current location. |
76855018 |
207 | |
208 | The data read will be returned. |
209 | |
210 | =cut |
211 | |
7dcefff3 |
212 | sub read_at { |
213 | my $self = shift; |
214 | my ($loc, $size) = @_; |
215 | |
216 | local ($/,$\); |
217 | |
218 | my $fh = $self->{fh}; |
219 | if ( defined $loc ) { |
220 | seek( $fh, $loc + $self->{file_offset}, SEEK_SET ); |
221 | } |
222 | |
695c88b1 |
223 | if ( DEBUG ) { |
224 | my $caller = join ':', (caller)[0,2]; |
225 | warn "($caller) read_at( " . (defined $loc ? $loc : '<undef>') . ", $size )\n"; |
226 | } |
227 | |
7dcefff3 |
228 | my $buffer; |
229 | read( $fh, $buffer, $size); |
230 | |
231 | return $buffer; |
232 | } |
233 | |
76855018 |
234 | =head2 DESTROY |
235 | |
d426259c |
236 | When the ::Storage::File object goes out of scope, it will be closed. |
76855018 |
237 | |
238 | =cut |
239 | |
460b1067 |
240 | sub DESTROY { |
241 | my $self = shift; |
242 | return unless $self; |
243 | |
244 | $self->close; |
245 | |
246 | return; |
247 | } |
248 | |
76855018 |
249 | =head2 request_space( $size ) |
250 | |
251 | This takes a size and adds that much space to the DBM. |
252 | |
253 | This returns the offset for the new location. |
254 | |
255 | =cut |
256 | |
019404df |
257 | sub request_space { |
258 | my $self = shift; |
259 | my ($size) = @_; |
260 | |
7dcefff3 |
261 | #XXX Do I need to reset $self->{end} here? I need a testcase |
019404df |
262 | my $loc = $self->{end}; |
263 | $self->{end} += $size; |
264 | |
265 | return $loc; |
266 | } |
267 | |
76855018 |
268 | =head2 copy_stats( $target_filename ) |
269 | |
270 | This will take the stats for the current filehandle and apply them to |
271 | C< $target_filename >. The stats copied are: |
272 | |
273 | =over 4 |
274 | |
275 | =item * Onwer UID and GID |
276 | |
277 | =item * Permissions |
278 | |
279 | =back |
280 | |
281 | =cut |
282 | |
283 | sub copy_stats { |
284 | my $self = shift; |
285 | my ($temp_filename) = @_; |
286 | |
287 | my @stats = stat( $self->{fh} ); |
288 | my $perms = $stats[2] & 07777; |
289 | my $uid = $stats[4]; |
290 | my $gid = $stats[5]; |
291 | chown( $uid, $gid, $temp_filename ); |
292 | chmod( $perms, $temp_filename ); |
293 | } |
294 | |
2c70efe1 |
295 | sub flush { |
296 | my $self = shift; |
76855018 |
297 | |
2c70efe1 |
298 | # Flush the filehandle |
299 | my $old_fh = select $self->{fh}; |
300 | my $old_af = $|; $| = 1; $| = $old_af; |
301 | select $old_fh; |
76855018 |
302 | |
2c70efe1 |
303 | return 1; |
304 | } |
76855018 |
305 | |
2c70efe1 |
306 | sub is_writable { |
307 | my $self = shift; |
76855018 |
308 | |
2c70efe1 |
309 | my $fh = $self->{fh}; |
310 | return unless defined $fh; |
311 | return unless defined fileno $fh; |
312 | local $\ = ''; # just in case |
313 | no warnings; # temporarily disable warnings |
314 | local $^W; # temporarily disable warnings |
315 | return print $fh ''; |
316 | } |
76855018 |
317 | |
5c0756fc |
318 | sub lock_exclusive { |
319 | my $self = shift; |
320 | my ($obj) = @_; |
76855018 |
321 | return $self->_lock( $obj, LOCK_EX ); |
5c0756fc |
322 | } |
323 | |
324 | sub lock_shared { |
325 | my $self = shift; |
326 | my ($obj) = @_; |
76855018 |
327 | return $self->_lock( $obj, LOCK_SH ); |
5c0756fc |
328 | } |
329 | |
76855018 |
330 | sub _lock { |
15ba72cc |
331 | my $self = shift; |
332 | my ($obj, $type) = @_; |
42717e46 |
333 | |
15ba72cc |
334 | $type = LOCK_EX unless defined $type; |
335 | |
45f047f8 |
336 | #XXX This is a temporary fix for Win32 and autovivification. It |
337 | # needs to improve somehow. -RobK, 2008-03-09 |
338 | if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) { |
339 | $type = LOCK_EX; |
340 | } |
341 | |
15ba72cc |
342 | if (!defined($self->{fh})) { return; } |
343 | |
45f047f8 |
344 | #XXX This either needs to allow for upgrading a shared lock to an |
345 | # exclusive lock or something else with autovivification. |
346 | # -RobK, 2008-03-09 |
15ba72cc |
347 | if ($self->{locking}) { |
348 | if (!$self->{locked}) { |
349 | flock($self->{fh}, $type); |
350 | |
351 | # refresh end counter in case file has changed size |
352 | my @stats = stat($self->{fh}); |
353 | $self->{end} = $stats[7]; |
354 | |
355 | # double-check file inode, in case another process |
356 | # has optimize()d our file while we were waiting. |
2120a181 |
357 | if (defined($self->{inode}) && $stats[1] != $self->{inode}) { |
15ba72cc |
358 | $self->close; |
359 | $self->open; |
360 | |
361 | #XXX This needs work |
f4d0ac97 |
362 | $obj->{engine}->setup( $obj ); |
15ba72cc |
363 | |
364 | flock($self->{fh}, $type); # re-lock |
365 | |
366 | # This may not be necessary after re-opening |
367 | $self->{end} = (stat($self->{fh}))[7]; # re-end |
368 | } |
369 | } |
370 | $self->{locked}++; |
371 | |
372 | return 1; |
373 | } |
374 | |
375 | return; |
376 | } |
377 | |
15ba72cc |
378 | sub unlock { |
379 | my $self = shift; |
380 | |
381 | if (!defined($self->{fh})) { return; } |
382 | |
383 | if ($self->{locking} && $self->{locked} > 0) { |
384 | $self->{locked}--; |
15ba72cc |
385 | |
a8d2331c |
386 | if (!$self->{locked}) { |
387 | flock($self->{fh}, LOCK_UN); |
388 | return 1; |
389 | } |
390 | |
391 | return; |
15ba72cc |
392 | } |
393 | |
394 | return; |
395 | } |
396 | |
460b1067 |
397 | 1; |
398 | __END__ |