line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Paranoid::BerkeleyDB::Env -- BerkeleyDB CDS Env |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# (c) 2005 - 2015, Arthur Corliss |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# $Id: lib/Paranoid/BerkeleyDB/Env.pm, 2.01 2016/06/17 11:24:54 acorliss Exp $ |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
# This software is licensed under the same terms as Perl, itself. |
8
|
|
|
|
|
|
|
# Please see http://dev.perl.org/licenses/ for more information. |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
##################################################################### |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
##################################################################### |
13
|
|
|
|
|
|
|
# |
14
|
|
|
|
|
|
|
# Environment definitions |
15
|
|
|
|
|
|
|
# |
16
|
|
|
|
|
|
|
##################################################################### |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
package Paranoid::BerkeleyDB::Env; |
19
|
|
|
|
|
|
|
|
20
|
2
|
|
|
2
|
|
30454
|
use strict; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
43
|
|
21
|
2
|
|
|
2
|
|
6
|
use warnings; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
39
|
|
22
|
2
|
|
|
2
|
|
5
|
use vars qw($VERSION); |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
59
|
|
23
|
2
|
|
|
2
|
|
6
|
use Fcntl qw(:DEFAULT :flock :mode :seek); |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
800
|
|
24
|
2
|
|
|
2
|
|
9
|
use Paranoid; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
62
|
|
25
|
2
|
|
|
2
|
|
6
|
use Paranoid::Debug qw(:all); |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
203
|
|
26
|
2
|
|
|
2
|
|
855
|
use Paranoid::IO; |
|
2
|
|
|
|
|
19121
|
|
|
2
|
|
|
|
|
136
|
|
27
|
2
|
|
|
2
|
|
780
|
use Paranoid::IO::Lockfile; |
|
2
|
|
|
|
|
1687
|
|
|
2
|
|
|
|
|
92
|
|
28
|
2
|
|
|
2
|
|
663
|
use Paranoid::BerkeleyDB::Core; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
use Class::EHierarchy qw(:all); |
30
|
|
|
|
|
|
|
use BerkeleyDB; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
($VERSION) = ( q$Revision: 2.01 $ =~ /(\d+(?:\.\d+)+)/sm ); |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
use vars qw(@ISA @_properties @_methods); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
@_properties = |
37
|
|
|
|
|
|
|
( [ CEH_PUB | CEH_SCALAR, 'home' ], [ CEH_PUB | CEH_HASH, 'params' ], ); |
38
|
|
|
|
|
|
|
@_methods = ( [ CEH_PUB, 'env' ], [ CEH_PUB, 'dbs' ], ); |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
@ISA = qw(Class::EHierarchy); |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
##################################################################### |
43
|
|
|
|
|
|
|
# |
44
|
|
|
|
|
|
|
# module code follows |
45
|
|
|
|
|
|
|
# |
46
|
|
|
|
|
|
|
##################################################################### |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
{ |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
my %dbe; # Object handles |
51
|
|
|
|
|
|
|
my %dbp; # Parameters used for handles |
52
|
|
|
|
|
|
|
my %dbc; # Reference count |
53
|
|
|
|
|
|
|
my %pid; # Object handle create PID |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
sub _openDbe { |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
# Purpose: Fork/redundant-open safe |
58
|
|
|
|
|
|
|
# Returns: Reference to BerkeleyDB::Env object |
59
|
|
|
|
|
|
|
# Usage: $env = _openDbe(%params); |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
my %params = @_; |
62
|
|
|
|
|
|
|
my ( $env, $fh ); |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
pdebug( 'entering w/%s', PDLEVEL2, %params ); |
65
|
|
|
|
|
|
|
pIn(); |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
if ( exists $dbe{ $params{'-Home'} } ) { |
68
|
|
|
|
|
|
|
pdebug( 'environment already exists', PDLEVEL3 ); |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
if ( $pid{ $params{'-Home'} } == $$ ) { |
71
|
|
|
|
|
|
|
pdebug( 'using cached reference', PDLEVEL3 ); |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
# Increment reference count |
74
|
|
|
|
|
|
|
$dbc{ $params{'-Home'} }++; |
75
|
|
|
|
|
|
|
$env = $dbe{ $params{'-Home'} }; |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
} else { |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
pdebug( 'cached ref created under different pid', PDLEVEL3 ); |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# Reuse prior parameters |
82
|
|
|
|
|
|
|
%params = %{ $dbp{ $params{'-Home'} } }; |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
# Install DESTROY filters |
85
|
|
|
|
|
|
|
_installScreener(); |
86
|
|
|
|
|
|
|
_addBlacklist( $dbe{ $params{'-Home'} } ); |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
# Close everything |
89
|
|
|
|
|
|
|
delete $dbe{ $params{'-Home'} }; |
90
|
|
|
|
|
|
|
delete $dbp{ $params{'-Home'} }; |
91
|
|
|
|
|
|
|
delete $dbc{ $params{'-Home'} }; |
92
|
|
|
|
|
|
|
delete $pid{ $params{'-Home'} }; |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
$env = _openDbe(%params); |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
} else { |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
pdebug( 'creating a new environment', PDLEVEL3 ); |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
# Create an error log |
103
|
|
|
|
|
|
|
$params{'-ErrFile'} = "$params{'-Home'}/db_err.log" |
104
|
|
|
|
|
|
|
unless exists $params{'-ErrFile'}; |
105
|
|
|
|
|
|
|
$fh = popen( $params{'-ErrFile'}, O_WRONLY | O_CREAT | O_APPEND ); |
106
|
|
|
|
|
|
|
$params{'-ErrFile'} = $fh if defined $fh; |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
# Add default flags if they're omitted |
109
|
|
|
|
|
|
|
$params{'-Mode'} = 0666 & ~umask; |
110
|
|
|
|
|
|
|
$params{'-Flags'} = DB_CREATE | DB_INIT_CDB | DB_INIT_MPOOL |
111
|
|
|
|
|
|
|
unless exists $params{'-Flags'}; |
112
|
|
|
|
|
|
|
$params{'-Verbose'} = 1; |
113
|
|
|
|
|
|
|
pdebug( 'final parameters: %s', PDLEVEL4, %params ); |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
# Create the environment |
116
|
|
|
|
|
|
|
if ( pexclock( "$params{'-Home'}/env.lock", $params{'-Mode'} ) ) { |
117
|
|
|
|
|
|
|
$env = BerkeleyDB::Env->new(%params); |
118
|
|
|
|
|
|
|
punlock("$params{'-Home'}/env.lock"); |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
if ( defined $env ) { |
122
|
|
|
|
|
|
|
$dbe{ $params{'-Home'} } = $env; |
123
|
|
|
|
|
|
|
$dbp{ $params{'-Home'} } = {%params}; |
124
|
|
|
|
|
|
|
$dbc{ $params{'-Home'} } = 1; |
125
|
|
|
|
|
|
|
$pid{ $params{'-Home'} } = $$; |
126
|
|
|
|
|
|
|
} else { |
127
|
|
|
|
|
|
|
Paranoid::ERROR = pdebug( 'failed to open environment: %s', |
128
|
|
|
|
|
|
|
PDLEVEL1, $BerkeleyDB::Error ); |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
pOut(); |
133
|
|
|
|
|
|
|
pdebug( 'leaving w/rv: %s', PDLEVEL2, $env ); |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
return $env; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
sub _closeDbe { |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
# Purpose: Close env or decrements counter |
141
|
|
|
|
|
|
|
# Returns: Boolean |
142
|
|
|
|
|
|
|
# Usage: $rv = _closeDbe(%params); |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
my %params = @_; |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
pdebug( 'entering w/%s', PDLEVEL2, %params ); |
147
|
|
|
|
|
|
|
pIn(); |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
if ( exists $dbe{ $params{'-Home'} } ) { |
150
|
|
|
|
|
|
|
if ( $dbc{ $params{'-Home'} } == 1 ) { |
151
|
|
|
|
|
|
|
pdebug( 'closing out environment', PDLEVEL4 ); |
152
|
|
|
|
|
|
|
delete $dbe{ $params{'-Home'} }; |
153
|
|
|
|
|
|
|
delete $dbp{ $params{'-Home'} }; |
154
|
|
|
|
|
|
|
delete $dbc{ $params{'-Home'} }; |
155
|
|
|
|
|
|
|
delete $pid{ $params{'-Home'} }; |
156
|
|
|
|
|
|
|
} else { |
157
|
|
|
|
|
|
|
pdebug( 'decrementing ref count', PDLEVEL4 ); |
158
|
|
|
|
|
|
|
$dbc{ $params{'-Home'} }--; |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
pOut(); |
163
|
|
|
|
|
|
|
pdebug( 'leaving w/rv: 1', PDLEVEL2 ); |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
return 1; |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
sub env { |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# Purpose: Returns a handle |
171
|
|
|
|
|
|
|
# Returns: Ref |
172
|
|
|
|
|
|
|
# Usage: $env = $obj->env; |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
my $obj = shift; |
175
|
|
|
|
|
|
|
my $home = $obj->property('home'); |
176
|
|
|
|
|
|
|
my $rv; |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
pdebug( 'entering', PDLEVEL1 ); |
179
|
|
|
|
|
|
|
pIn(); |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
$rv = $$ == $pid{$home} |
182
|
|
|
|
|
|
|
? $rv = $dbe{$home} |
183
|
|
|
|
|
|
|
: _openDbe( $obj->property('params') ); |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
pOut(); |
186
|
|
|
|
|
|
|
pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv ); |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
return $rv; |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
sub _initialize { |
193
|
|
|
|
|
|
|
my $obj = shift; |
194
|
|
|
|
|
|
|
my %params = @_; |
195
|
|
|
|
|
|
|
my $rv; |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
# Make sure minimal parameters are preset |
198
|
|
|
|
|
|
|
pdebug( 'entering', PDLEVEL1 ); |
199
|
|
|
|
|
|
|
pIn(); |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
if ( exists $params{'-Home'} ) { |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
if ( defined _openDbe(%params) ) { |
204
|
|
|
|
|
|
|
$obj->property( 'home', $params{'-Home'} ); |
205
|
|
|
|
|
|
|
$obj->property( 'params', %params ); |
206
|
|
|
|
|
|
|
$rv = 1; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
} else { |
210
|
|
|
|
|
|
|
Paranoid::ERROR = pdebug( 'caller didn\'t specify -Home', PDLEVEL1 ); |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
pOut(); |
214
|
|
|
|
|
|
|
pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv ); |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
return $rv; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
sub _deconstruct { |
220
|
|
|
|
|
|
|
my $obj = shift; |
221
|
|
|
|
|
|
|
my %params = $obj->property('params'); |
222
|
|
|
|
|
|
|
my ( $rv, $db ); |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
pdebug( 'entering', PDLEVEL1 ); |
225
|
|
|
|
|
|
|
pIn(); |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
foreach ( $obj->children ) { |
228
|
|
|
|
|
|
|
$obj->disown($_); |
229
|
|
|
|
|
|
|
$_ = undef; |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
$rv = _closeDbe(%params); |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
pOut(); |
234
|
|
|
|
|
|
|
pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv ); |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
return $rv; |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
sub dbs { |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
# Purpose: Returns a list of database objects using this env |
242
|
|
|
|
|
|
|
# Returns: List of objects |
243
|
|
|
|
|
|
|
# Usage: @dbs = $dbe->dbs; |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
my $obj = shift; |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
return |
248
|
|
|
|
|
|
|
grep { defined $_ and $_->isa('Paranoid::BerkeleyDB::Db') } |
249
|
|
|
|
|
|
|
$obj->children; |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
1; |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
__END__ |