Commit | Line | Data |
460b1067 |
1 | package DBM::Deep::File; |
2 | |
2120a181 |
3 | use 5.006_000; |
460b1067 |
4 | |
5 | use strict; |
6 | use warnings; |
7 | |
6e6789b0 |
8 | our $VERSION = q(1.0009); |
460b1067 |
9 | |
86867f3a |
10 | use Fcntl qw( :DEFAULT :flock :seek ); |
6e6789b0 |
11 | use FileHandle::Fmode (); |
460b1067 |
12 | |
13 | sub new { |
14 | my $class = shift; |
15 | my ($args) = @_; |
16 | |
17 | my $self = bless { |
359a01ac |
18 | autobless => 1, |
2120a181 |
19 | autoflush => 1, |
460b1067 |
20 | end => 0, |
21 | fh => undef, |
22 | file => undef, |
23 | file_offset => 0, |
2120a181 |
24 | locking => 1, |
460b1067 |
25 | locked => 0, |
2120a181 |
26 | #XXX Migrate this to the engine, where it really belongs. |
460b1067 |
27 | filter_store_key => undef, |
28 | filter_store_value => undef, |
29 | filter_fetch_key => undef, |
30 | filter_fetch_value => undef, |
31 | }, $class; |
32 | |
33 | # Grab the parameters we want to use |
34 | foreach my $param ( keys %$self ) { |
35 | next unless exists $args->{$param}; |
36 | $self->{$param} = $args->{$param}; |
37 | } |
38 | |
39 | if ( $self->{fh} && !$self->{file_offset} ) { |
40 | $self->{file_offset} = tell( $self->{fh} ); |
41 | } |
42 | |
43 | $self->open unless $self->{fh}; |
44 | |
45 | return $self; |
46 | } |
47 | |
48 | sub open { |
49 | my $self = shift; |
50 | |
633df1fd |
51 | # Adding O_BINARY should remove the need for the binmode below. However, |
460b1067 |
52 | # I'm not going to remove it because I don't have the Win32 chops to be |
53 | # absolutely certain everything will be ok. |
e9b0b5f0 |
54 | my $flags = O_CREAT | O_BINARY; |
55 | |
56 | if ( !-e $self->{file} || -w _ ) { |
57 | $flags |= O_RDWR; |
58 | } |
59 | else { |
60 | $flags |= O_RDONLY; |
61 | } |
460b1067 |
62 | |
63 | my $fh; |
64 | sysopen( $fh, $self->{file}, $flags ) |
65 | or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n"; |
66 | $self->{fh} = $fh; |
67 | |
68 | # Even though we use O_BINARY, better be safe than sorry. |
69 | binmode $fh; |
70 | |
71 | if ($self->{autoflush}) { |
72 | my $old = select $fh; |
73 | $|=1; |
74 | select $old; |
75 | } |
76 | |
77 | return 1; |
78 | } |
79 | |
80 | sub close { |
81 | my $self = shift; |
82 | |
83 | if ( $self->{fh} ) { |
84 | close $self->{fh}; |
85 | $self->{fh} = undef; |
86 | } |
87 | |
88 | return 1; |
89 | } |
90 | |
7dcefff3 |
91 | sub set_inode { |
92 | my $self = shift; |
93 | |
2120a181 |
94 | unless ( defined $self->{inode} ) { |
7dcefff3 |
95 | my @stats = stat($self->{fh}); |
96 | $self->{inode} = $stats[1]; |
97 | $self->{end} = $stats[7]; |
98 | } |
99 | |
100 | return 1; |
101 | } |
102 | |
019404df |
103 | sub print_at { |
104 | my $self = shift; |
105 | my $loc = shift; |
106 | |
107 | local ($/,$\); |
108 | |
109 | my $fh = $self->{fh}; |
7dcefff3 |
110 | if ( defined $loc ) { |
111 | seek( $fh, $loc + $self->{file_offset}, SEEK_SET ); |
112 | } |
113 | |
45f047f8 |
114 | print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n"; |
019404df |
115 | |
116 | return 1; |
117 | } |
118 | |
7dcefff3 |
119 | sub read_at { |
120 | my $self = shift; |
121 | my ($loc, $size) = @_; |
122 | |
123 | local ($/,$\); |
124 | |
125 | my $fh = $self->{fh}; |
126 | if ( defined $loc ) { |
127 | seek( $fh, $loc + $self->{file_offset}, SEEK_SET ); |
128 | } |
129 | |
130 | my $buffer; |
131 | read( $fh, $buffer, $size); |
132 | |
133 | return $buffer; |
134 | } |
135 | |
460b1067 |
136 | sub DESTROY { |
137 | my $self = shift; |
138 | return unless $self; |
139 | |
140 | $self->close; |
141 | |
142 | return; |
143 | } |
144 | |
019404df |
145 | sub request_space { |
146 | my $self = shift; |
147 | my ($size) = @_; |
148 | |
7dcefff3 |
149 | #XXX Do I need to reset $self->{end} here? I need a testcase |
019404df |
150 | my $loc = $self->{end}; |
151 | $self->{end} += $size; |
152 | |
153 | return $loc; |
154 | } |
155 | |
15ba72cc |
156 | ## |
157 | # If db locking is set, flock() the db file. If called multiple |
158 | # times before unlock(), then the same number of unlocks() must |
159 | # be called before the lock is released. |
160 | ## |
161 | sub lock { |
162 | my $self = shift; |
163 | my ($obj, $type) = @_; |
42717e46 |
164 | |
15ba72cc |
165 | $type = LOCK_EX unless defined $type; |
166 | |
45f047f8 |
167 | #XXX This is a temporary fix for Win32 and autovivification. It |
168 | # needs to improve somehow. -RobK, 2008-03-09 |
169 | if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) { |
170 | $type = LOCK_EX; |
171 | } |
172 | |
15ba72cc |
173 | if (!defined($self->{fh})) { return; } |
174 | |
45f047f8 |
175 | #XXX This either needs to allow for upgrading a shared lock to an |
176 | # exclusive lock or something else with autovivification. |
177 | # -RobK, 2008-03-09 |
15ba72cc |
178 | if ($self->{locking}) { |
179 | if (!$self->{locked}) { |
180 | flock($self->{fh}, $type); |
181 | |
182 | # refresh end counter in case file has changed size |
183 | my @stats = stat($self->{fh}); |
184 | $self->{end} = $stats[7]; |
185 | |
186 | # double-check file inode, in case another process |
187 | # has optimize()d our file while we were waiting. |
2120a181 |
188 | if (defined($self->{inode}) && $stats[1] != $self->{inode}) { |
15ba72cc |
189 | $self->close; |
190 | $self->open; |
191 | |
192 | #XXX This needs work |
193 | $obj->{engine}->setup_fh( $obj ); |
194 | |
195 | flock($self->{fh}, $type); # re-lock |
196 | |
197 | # This may not be necessary after re-opening |
198 | $self->{end} = (stat($self->{fh}))[7]; # re-end |
199 | } |
200 | } |
201 | $self->{locked}++; |
202 | |
203 | return 1; |
204 | } |
205 | |
206 | return; |
207 | } |
208 | |
209 | ## |
210 | # If db locking is set, unlock the db file. See note in lock() |
211 | # regarding calling lock() multiple times. |
212 | ## |
213 | sub unlock { |
214 | my $self = shift; |
215 | |
216 | if (!defined($self->{fh})) { return; } |
217 | |
218 | if ($self->{locking} && $self->{locked} > 0) { |
219 | $self->{locked}--; |
220 | if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); } |
221 | |
222 | return 1; |
223 | } |
224 | |
225 | return; |
226 | } |
227 | |
2120a181 |
228 | sub flush { |
25c7c8d6 |
229 | my $self = shift; |
230 | |
2120a181 |
231 | # Flush the filehandle |
232 | my $old_fh = select $self->{fh}; |
233 | my $old_af = $|; $| = 1; $| = $old_af; |
234 | select $old_fh; |
25c7c8d6 |
235 | |
236 | return 1; |
237 | } |
28394a1a |
238 | |
6e6789b0 |
239 | sub is_writable { |
240 | my $self = shift; |
241 | return FileHandle::Fmode::is_W( $self->{fh} ); |
242 | } |
243 | |
244 | sub copy_stats { |
245 | my $self = shift; |
246 | my ($temp_filename) = @_; |
247 | |
248 | my @stats = stat( $self->{fh} ); |
249 | my $perms = $stats[2] & 07777; |
250 | my $uid = $stats[4]; |
251 | my $gid = $stats[5]; |
252 | chown( $uid, $gid, $temp_filename ); |
253 | chmod( $perms, $temp_filename ); |
254 | } |
255 | |
460b1067 |
256 | 1; |
257 | __END__ |