1 package DBM::Deep::File;
6 use warnings FATAL => 'all';
8 use Fcntl qw( :DEFAULT :flock :seek );
10 use constant DEBUG => 1;
25 #XXX Migrate this to the engine, where it really belongs.
26 filter_store_key => undef,
27 filter_store_value => undef,
28 filter_fetch_key => undef,
29 filter_fetch_value => undef,
32 # Grab the parameters we want to use
33 foreach my $param ( keys %$self ) {
34 next unless exists $args->{$param};
35 $self->{$param} = $args->{$param};
38 if ( $self->{fh} && !$self->{file_offset} ) {
39 $self->{file_offset} = tell( $self->{fh} );
42 $self->open unless $self->{fh};
50 # Adding O_BINARY should remove the need for the binmode below. However,
51 # I'm not going to remove it because I don't have the Win32 chops to be
52 # absolutely certain everything will be ok.
53 my $flags = O_CREAT | O_BINARY;
55 if ( !-e $self->{file} || -w _ ) {
63 sysopen( $fh, $self->{file}, $flags )
64 or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
67 # Even though we use O_BINARY, better be safe than sorry.
70 if ($self->{autoflush}) {
93 return 0 unless $self->{fh};
94 return -s $self->{fh};
100 unless ( defined $self->{inode} ) {
101 my @stats = stat($self->{fh});
102 $self->{inode} = $stats[1];
103 $self->{end} = $stats[7];
113 warn "print_at called\n";
116 my $fh = $self->{fh};
117 if ( defined $loc ) {
118 seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
122 my $caller = join ':', (caller)[0,2];
123 my $len = length( join '', @_ );
124 warn "($caller) print_at( " . (defined $loc ? $loc : '<undef>') . ", $len )\n";
127 print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n";
134 my ($loc, $size) = @_;
138 my $fh = $self->{fh};
139 if ( defined $loc ) {
140 seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
144 my $caller = join ':', (caller)[0,2];
145 warn "($caller) read_at( " . (defined $loc ? $loc : '<undef>') . ", $size )\n";
149 read( $fh, $buffer, $size);
167 #XXX Do I need to reset $self->{end} here? I need a testcase
168 my $loc = $self->{end};
169 $self->{end} += $size;
175 # If db locking is set, flock() the db file. If called multiple
176 # times before unlock(), then the same number of unlocks() must
177 # be called before the lock is released.
182 return $self->lock( $obj, LOCK_EX );
188 return $self->lock( $obj, LOCK_SH );
193 my ($obj, $type) = @_;
195 $type = LOCK_EX unless defined $type;
197 #XXX This is a temporary fix for Win32 and autovivification. It
198 # needs to improve somehow. -RobK, 2008-03-09
199 if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
203 if (!defined($self->{fh})) { return; }
205 #XXX This either needs to allow for upgrading a shared lock to an
206 # exclusive lock or something else with autovivification.
208 if ($self->{locking}) {
209 if (!$self->{locked}) {
210 flock($self->{fh}, $type);
212 # refresh end counter in case file has changed size
213 my @stats = stat($self->{fh});
214 $self->{end} = $stats[7];
216 # double-check file inode, in case another process
217 # has optimize()d our file while we were waiting.
218 if (defined($self->{inode}) && $stats[1] != $self->{inode}) {
223 $obj->{engine}->setup_fh( $obj );
225 flock($self->{fh}, $type); # re-lock
227 # This may not be necessary after re-opening
228 $self->{end} = (stat($self->{fh}))[7]; # re-end
240 # If db locking is set, unlock the db file. See note in lock()
241 # regarding calling lock() multiple times.
246 if (!defined($self->{fh})) { return; }
248 if ($self->{locking} && $self->{locked} > 0) {
251 if (!$self->{locked}) {
252 flock($self->{fh}, LOCK_UN);
265 # Flush the filehandle
266 my $old_fh = select $self->{fh};
267 my $old_af = $|; $| = 1; $| = $old_af;
273 # Taken from http://www.perlmonks.org/?node_id=691054
277 my $fh = $self->{fh};
278 return unless defined $fh;
279 return unless defined fileno $fh;
280 local $\ = ''; # just in case
281 no warnings; # temporarily disable warnings
282 local $^W; # temporarily disable warnings
288 my ($temp_filename) = @_;
290 my @stats = stat( $self->{fh} );
291 my $perms = $stats[2] & 07777;
294 chown( $uid, $gid, $temp_filename );
295 chmod( $perms, $temp_filename );