Merged with master and am ready to merge back
[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
2c70efe1 12use base 'DBM::Deep::Storage';
13
76855018 14=head1 NAME
15
d426259c 16DBM::Deep::Storage::File
76855018 17
18=head1 PURPOSE
19
1c62d370 20This is an internal-use-only object for L<DBM::Deep>. It mediates the low-level
76855018 21interaction with the storage mechanism.
22
23Currently, the only storage mechanism supported is the file system.
24
25=head1 OVERVIEW
26
d426259c 27This 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 36sub 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
73This method opens the filehandle for the filename in C< file >.
74
75There is no return value.
76
77=cut
78
a4d36ff6 79# TODO: What happens if we ->open when we already have a $fh?
460b1067 80sub 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
114If the filehandle is opened, this will close it.
115
116There is no return value.
117
118=cut
119
460b1067 120sub 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
133This will return the size of the DB. If file_offset is set, this will take that into account.
134
417f635b 135B<NOTE>: This function isn't used internally anywhere.
136
76855018 137=cut
138
00d9bd0b 139sub 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
148This will set the inode value of the underlying file object.
149
d426259c 150This is only needed to handle some obscure Win32 bugs. It reqlly shouldn't be
151needed outside this object.
76855018 152
153There is no return value.
154
155=cut
156
7dcefff3 157sub 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
171This takes an optional offset and some data to print.
172
d426259c 173C< $offset >, if defined, will be used to seek into the file. If file_offset is
174set, it will be used as the zero location. If it is undefined, no seeking will
175occur. Then, C< @data > will be printed to the current location.
76855018 176
177There is no return value.
178
179=cut
180
019404df 181sub 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
205This takes an optional offset and a length.
206
d426259c 207C< $offset >, if defined, will be used to seek into the file. If file_offset is
208set, it will be used as the zero location. If it is undefined, no seeking will
209occur. Then, C< $length > bytes will be read from the current location.
76855018 210
211The data read will be returned.
212
213=cut
214
7dcefff3 215sub 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 237When the ::Storage::File object goes out of scope, it will be closed.
76855018 238
239=cut
240
460b1067 241sub 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
252This takes a size and adds that much space to the DBM.
253
254This returns the offset for the new location.
255
256=cut
257
019404df 258sub 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
271This will take the stats for the current filehandle and apply them to
272C< $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
284sub 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 296sub 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 307sub 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 319sub lock_exclusive {
320 my $self = shift;
321 my ($obj) = @_;
76855018 322 return $self->_lock( $obj, LOCK_EX );
5c0756fc 323}
324
325sub lock_shared {
326 my $self = shift;
327 my ($obj) = @_;
76855018 328 return $self->_lock( $obj, LOCK_SH );
5c0756fc 329}
330
76855018 331sub _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 379sub 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 3981;
399__END__