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