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