r6122@000-443-371 (orig r9951): rkinyon | 2007-09-19 22:33:23 -0400
[dbsrgits/DBM-Deep.git] / lib / DBM / Deep / File.pm
1 package DBM::Deep::File;
2
3 use 5.006_000;
4
5 use strict;
6 use warnings;
7
8 our $VERSION = q(1.0002);
9
10 use Fcntl qw( :DEFAULT :flock :seek );
11
12 sub new {
13     my $class = shift;
14     my ($args) = @_;
15
16     my $self = bless {
17         autobless          => 1,
18         autoflush          => 1,
19         end                => 0,
20         fh                 => undef,
21         file               => undef,
22         file_offset        => 0,
23         locking            => 1,
24         locked             => 0,
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,
30     }, $class;
31
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};
36     }
37
38     if ( $self->{fh} && !$self->{file_offset} ) {
39         $self->{file_offset} = tell( $self->{fh} );
40     }
41
42     $self->open unless $self->{fh};
43
44     return $self;
45 }
46
47 sub open {
48     my $self = shift;
49
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;
54
55     if ( !-e $self->{file} || -w _ ) {
56       $flags |= O_RDWR;
57     }
58     else {
59       $flags |= O_RDONLY;
60     }
61
62     my $fh;
63     sysopen( $fh, $self->{file}, $flags )
64         or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
65     $self->{fh} = $fh;
66
67     # Even though we use O_BINARY, better be safe than sorry.
68     binmode $fh;
69
70     if ($self->{autoflush}) {
71         my $old = select $fh;
72         $|=1;
73         select $old;
74     }
75
76     return 1;
77 }
78
79 sub close {
80     my $self = shift;
81
82     if ( $self->{fh} ) {
83         close $self->{fh};
84         $self->{fh} = undef;
85     }
86
87     return 1;
88 }
89
90 sub set_inode {
91     my $self = shift;
92
93     unless ( defined $self->{inode} ) {
94         my @stats = stat($self->{fh});
95         $self->{inode} = $stats[1];
96         $self->{end} = $stats[7];
97     }
98
99     return 1;
100 }
101
102 sub print_at {
103     my $self = shift;
104     my $loc  = shift;
105
106     local ($/,$\);
107
108     my $fh = $self->{fh};
109     if ( defined $loc ) {
110         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
111     }
112
113     print( $fh @_ );
114
115     return 1;
116 }
117
118 sub read_at {
119     my $self = shift;
120     my ($loc, $size) = @_;
121
122     local ($/,$\);
123
124     my $fh = $self->{fh};
125     if ( defined $loc ) {
126         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
127     }
128
129     my $buffer;
130     read( $fh, $buffer, $size);
131
132     return $buffer;
133 }
134
135 sub DESTROY {
136     my $self = shift;
137     return unless $self;
138
139     $self->close;
140
141     return;
142 }
143
144 sub request_space {
145     my $self = shift;
146     my ($size) = @_;
147
148     #XXX Do I need to reset $self->{end} here? I need a testcase
149     my $loc = $self->{end};
150     $self->{end} += $size;
151
152     return $loc;
153 }
154
155 ##
156 # If db locking is set, flock() the db file.  If called multiple
157 # times before unlock(), then the same number of unlocks() must
158 # be called before the lock is released.
159 ##
160 sub lock {
161     my $self = shift;
162     my ($obj, $type) = @_;
163
164     $type = LOCK_EX unless defined $type;
165
166     if (!defined($self->{fh})) { return; }
167
168     if ($self->{locking}) {
169         if (!$self->{locked}) {
170             flock($self->{fh}, $type);
171
172             # refresh end counter in case file has changed size
173             my @stats = stat($self->{fh});
174             $self->{end} = $stats[7];
175
176             # double-check file inode, in case another process
177             # has optimize()d our file while we were waiting.
178             if (defined($self->{inode}) && $stats[1] != $self->{inode}) {
179                 $self->close;
180                 $self->open;
181
182                 #XXX This needs work
183                 $obj->{engine}->setup_fh( $obj );
184
185                 flock($self->{fh}, $type); # re-lock
186
187                 # This may not be necessary after re-opening
188                 $self->{end} = (stat($self->{fh}))[7]; # re-end
189             }
190         }
191         $self->{locked}++;
192
193         return 1;
194     }
195
196     return;
197 }
198
199 ##
200 # If db locking is set, unlock the db file.  See note in lock()
201 # regarding calling lock() multiple times.
202 ##
203 sub unlock {
204     my $self = shift;
205
206     if (!defined($self->{fh})) { return; }
207
208     if ($self->{locking} && $self->{locked} > 0) {
209         $self->{locked}--;
210         if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); }
211
212         return 1;
213     }
214
215     return;
216 }
217
218 sub flush {
219     my $self = shift;
220
221     # Flush the filehandle
222     my $old_fh = select $self->{fh};
223     my $old_af = $|; $| = 1; $| = $old_af;
224     select $old_fh;
225
226     return 1;
227 }
228
229 1;
230 __END__