line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# $Id: SQLite_File.pm 16252 2009-10-09 22:26:34Z maj $ |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# converted from Bio::DB::SQLite_File for PAUSE upload |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
=head1 NAME |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
SQLite_File - Tie to SQLite, with DB_File emulation |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
=head1 SYNOPSIS |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# tie a simple hash to a SQLite DB file |
13
|
|
|
|
|
|
|
my %db; |
14
|
|
|
|
|
|
|
tie(%db, 'SQLite_File', 'my.db'); |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
# tie an array |
17
|
|
|
|
|
|
|
my @db; |
18
|
|
|
|
|
|
|
tie(@db, 'SQLite_File', 'my.db'); |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
# tie to a tempfile |
21
|
|
|
|
|
|
|
tie(%db, 'SQLite_File', undef); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
# get attributes of the tied object |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
$SQLite_handle = (tied %db)->dbh; |
26
|
|
|
|
|
|
|
$db_file = (tied %db)->file; |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
# use as an option in AnyDBM_File |
29
|
|
|
|
|
|
|
@AnyDBM_File::ISA = qw( DB_File SQLite_File SDBM ); |
30
|
|
|
|
|
|
|
my %db; |
31
|
|
|
|
|
|
|
tie(%db, 'AnyDBM_File', 'my.db', @dbmargs) |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
# Filter with DBM_Filter |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
use DBM_Filter; |
36
|
|
|
|
|
|
|
tie(%db, 'SQLite_File', 'my.db'); |
37
|
|
|
|
|
|
|
(tied %db)->Filter_Push('utf8'); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
=head1 DESCRIPTION |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
This module allows a hash or an array to be tied to a SQLite DB via |
42
|
|
|
|
|
|
|
L plus L, in a way that emulates many features of |
43
|
|
|
|
|
|
|
Berkeley-DB-based L. In particular, this module offers another |
44
|
|
|
|
|
|
|
choice for ActiveState users, who may find it difficult to get a |
45
|
|
|
|
|
|
|
working L installed, but can't failover to SDBM due to its |
46
|
|
|
|
|
|
|
record length restrictions. SQLite_File requires |
47
|
|
|
|
|
|
|
L, which has SQLite built-in -- no external application |
48
|
|
|
|
|
|
|
install required. |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
=head2 Key/Value filters |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
The filter hooks C, C, C, and C are honored. L can be used as an API. |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
=head2 DB_File Emulation |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
The intention was to create a DBM that could almost completely substitute for |
57
|
|
|
|
|
|
|
C, so that C could be replaced everywhere in code by |
58
|
|
|
|
|
|
|
C, and things would just work. Currently, it is slightly more |
59
|
|
|
|
|
|
|
complicated than that, but not too much more. |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
Versions of C<$DB_HASH>, C<$DB_BTREE>, and C<$DB_RECNO>, as well as |
62
|
|
|
|
|
|
|
the necessary flags (C, C, C, etc.) are |
63
|
|
|
|
|
|
|
imported by using the L module. The desired |
64
|
|
|
|
|
|
|
constants need to be declared global in the calling program, as well |
65
|
|
|
|
|
|
|
as imported, to avoid compilation errors (at this point). See |
66
|
|
|
|
|
|
|
L below. |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
Arguments to the C function mirror those of C, and all should |
69
|
|
|
|
|
|
|
work the same way. See L. |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
All of C's random and sequential access functions work: |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
get() |
74
|
|
|
|
|
|
|
put() |
75
|
|
|
|
|
|
|
del() |
76
|
|
|
|
|
|
|
seq() |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
as well as the duplicate key handlers |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
get_dup() |
81
|
|
|
|
|
|
|
del_dup() |
82
|
|
|
|
|
|
|
find_dup() |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
C works by finding partial matches, like C. |
85
|
|
|
|
|
|
|
The extra array functions ( C, C, etc. ) are not yet |
86
|
|
|
|
|
|
|
implemented as method calls, though all these functions (including |
87
|
|
|
|
|
|
|
C are available on the tied arrays. |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
Some C fields are functional: |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
$DB_BTREE->{'compare'} = sub { - shift cmp shift }; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
will provide sequential access in reverse lexographic order, for example. |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
$DB_HASH->{'cachesize'} = 20000; |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
will enforce C. |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
=head2 Converting from DB_File |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
To failover to C from C, go from this: |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
use DB_File; |
104
|
|
|
|
|
|
|
# ... |
105
|
|
|
|
|
|
|
$DB_BTREE->{cachesize} = 100000; |
106
|
|
|
|
|
|
|
$DB_BTREE->{flags} = R_DUP; |
107
|
|
|
|
|
|
|
my %db; |
108
|
|
|
|
|
|
|
my $obj = tie( %db, 'DB_File', 'my.db', $flags, 0666, $DB_BTREE); |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
to this: |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
use vars qw( $DB_HASH &R_DUP ); |
113
|
|
|
|
|
|
|
BEGIN { |
114
|
|
|
|
|
|
|
@AnyDBM_File::ISA = qw( DB_File SQLite_File ) |
115
|
|
|
|
|
|
|
unless @AnyDBM_File::ISA == 1; # |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
use AnyDBM_File; |
118
|
|
|
|
|
|
|
use AnyDBMImporter qw(:bdb); |
119
|
|
|
|
|
|
|
# ... |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
$DB_BTREE->{cachesize} = 100000; |
122
|
|
|
|
|
|
|
$DB_BTREE->{flags} = R_DUP; |
123
|
|
|
|
|
|
|
my %db; |
124
|
|
|
|
|
|
|
my $obj = tie( %db, 'AnyDBM_File', 'my.db', $flags, 0666, $DB_BTREE); |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
=head1 SEE ALSO |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
L, L, L, L |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
=head1 AUTHOR |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
Mark A. Jensen < MAJENSEN -at- cpan -dot- org > |
133
|
|
|
|
|
|
|
http://fortinbras.us |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
=head1 CONTRIBUTORS |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
This code owes an intellectual debt to Lincoln Stein. Inelegancies and |
138
|
|
|
|
|
|
|
bugs are mine. |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
Thanks to Barry C. and "Justin Case". |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
(c) 2009-2017 Mark A. Jensen |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
This program is free software; you can redistribute |
147
|
|
|
|
|
|
|
it and/or modify it under the same terms as Perl itself. |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
The full text of the license can be found in the |
150
|
|
|
|
|
|
|
LICENSE file included with this module. |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
=cut |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
package SQLite_File; |
155
|
6
|
|
|
6
|
|
694548
|
use base qw/Tie::Hash Tie::Array Exporter/; |
|
6
|
|
|
|
|
20
|
|
|
6
|
|
|
|
|
2488
|
|
156
|
6
|
|
|
6
|
|
14304
|
use strict; |
|
6
|
|
|
|
|
20
|
|
|
6
|
|
|
|
|
165
|
|
157
|
6
|
|
|
6
|
|
43
|
use warnings; |
|
6
|
|
|
|
|
20
|
|
|
6
|
|
|
|
|
328
|
|
158
|
|
|
|
|
|
|
our $VERSION = '0.1004'; |
159
|
|
|
|
|
|
|
|
160
|
6
|
|
|
6
|
|
75
|
use vars qw( $AUTOLOAD ) ; |
|
6
|
|
|
|
|
18
|
|
|
6
|
|
|
|
|
373
|
|
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
BEGIN { |
163
|
6
|
50
|
|
6
|
|
419
|
unless (eval "require DBD::SQLite; 1") { |
164
|
0
|
|
|
|
|
0
|
croak( "SQLite_File requires DBD::SQLite" ); |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
6
|
|
|
6
|
|
54
|
use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC); |
|
6
|
|
|
|
|
16
|
|
|
6
|
|
|
|
|
456
|
|
169
|
6
|
|
|
6
|
|
42
|
use DBI qw(:sql_types); |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
2890
|
|
170
|
6
|
|
|
6
|
|
3498
|
use File::Temp qw( tempfile ); |
|
6
|
|
|
|
|
117877
|
|
|
6
|
|
|
|
|
520
|
|
171
|
6
|
|
|
6
|
|
68
|
use Carp; |
|
6
|
|
|
|
|
19
|
|
|
6
|
|
|
|
|
57699
|
|
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
our @EXPORT_OK = qw( |
174
|
|
|
|
|
|
|
$DB_HASH $DB_BTREE $DB_RECNO |
175
|
|
|
|
|
|
|
R_DUP R_CURSOR R_FIRST R_LAST |
176
|
|
|
|
|
|
|
R_NEXT R_PREV R_IAFTER R_IBEFORE |
177
|
|
|
|
|
|
|
R_NOOVERWRITE R_SETCURSOR |
178
|
|
|
|
|
|
|
O_CREAT O_RDWR O_RDONLY O_SVWST |
179
|
|
|
|
|
|
|
O_TRUNC |
180
|
|
|
|
|
|
|
); |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
our $DB_HASH = new SQLite_File::HASHINFO; |
183
|
|
|
|
|
|
|
our $DB_BTREE = new SQLite_File::BTREEINFO; |
184
|
|
|
|
|
|
|
our $DB_RECNO = new SQLite_File::RECNOINFO; |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
# constants hacked out of DB_File: |
187
|
5
|
|
|
5
|
0
|
1355
|
sub R_DUP { 32678 } |
188
|
74
|
|
|
74
|
0
|
411
|
sub R_CURSOR { 27 } |
189
|
34
|
|
|
34
|
0
|
138
|
sub R_FIRST { 7 } |
190
|
26
|
|
|
26
|
0
|
77
|
sub R_LAST { 15 } |
191
|
32
|
|
|
32
|
0
|
115
|
sub R_NEXT { 16 } |
192
|
8
|
|
|
8
|
0
|
25
|
sub R_PREV { 23 } |
193
|
4
|
|
|
4
|
0
|
16
|
sub R_IAFTER { 1 } |
194
|
3
|
|
|
3
|
0
|
13
|
sub R_IBEFORE { 3 } |
195
|
2
|
|
|
2
|
0
|
8
|
sub R_NOOVERWRITE { 20 } |
196
|
7
|
|
|
7
|
0
|
28
|
sub R_SETCURSOR { -100 } |
197
|
0
|
|
|
0
|
0
|
0
|
sub O_SVWST { O_CREAT() | O_RDWR() }; |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
$SQLite_File::MAXPEND = 250; |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
our $AUTOKEY = 0; |
202
|
|
|
|
|
|
|
# for providing DB_File seq functionality |
203
|
|
|
|
|
|
|
our $AUTOPK = 0; |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
# statement tables |
206
|
|
|
|
|
|
|
our %STMT = ( |
207
|
|
|
|
|
|
|
HASH => { |
208
|
|
|
|
|
|
|
put => "INSERT INTO hash (id, obj, pk) VALUES ( ?, ?, ? )", |
209
|
|
|
|
|
|
|
put_seq => "INSERT INTO hash (id, obj, pk) VALUES ( ?, ?, ? )", |
210
|
|
|
|
|
|
|
get => "SELECT obj, pk FROM hash WHERE id = ?", |
211
|
|
|
|
|
|
|
get_seq => "SELECT id, obj FROM hash WHERE pk = ?", |
212
|
|
|
|
|
|
|
upd => "UPDATE hash SET obj = ? WHERE id = ? AND pk = ?", |
213
|
|
|
|
|
|
|
upd_seq => "UPDATE hash SET id = ?, obj = ? WHERE pk = ?", |
214
|
|
|
|
|
|
|
del => "DELETE FROM hash WHERE id = ?", |
215
|
|
|
|
|
|
|
del_seq => "DELETE FROM hash WHERE pk = ?", |
216
|
|
|
|
|
|
|
del_dup => "DELETE FROM hash WHERE id = ? AND obj = ?", |
217
|
|
|
|
|
|
|
sel_dup => "SELECT pk FROM hash WHERE id = ? AND obj = ?", |
218
|
|
|
|
|
|
|
part_seq=> "SELECT id, obj, pk FROM hash WHERE id >= ? LIMIT 1" |
219
|
|
|
|
|
|
|
}, |
220
|
|
|
|
|
|
|
ARRAY => { |
221
|
|
|
|
|
|
|
put => "INSERT INTO hash (id, obj) VALUES ( ?, ?)", |
222
|
|
|
|
|
|
|
put_seq => "INSERT INTO hash (obj, id) VALUES ( ?, ?)", |
223
|
|
|
|
|
|
|
get => "SELECT obj, id FROM hash WHERE id = ?", |
224
|
|
|
|
|
|
|
get_seq => "SELECT id, obj FROM hash WHERE id = ?", |
225
|
|
|
|
|
|
|
upd => "UPDATE hash SET obj = ? WHERE id = ?", |
226
|
|
|
|
|
|
|
upd_seq => "UPDATE hash SET obj = ? WHERE id = ?", |
227
|
|
|
|
|
|
|
del => "DELETE FROM hash WHERE id = ?", |
228
|
|
|
|
|
|
|
del_seq => "DELETE FROM hash WHERE id = ?" |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
); |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
# our own private index |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
sub SEQIDX { |
235
|
249
|
|
|
249
|
0
|
405
|
my $self = shift; |
236
|
249
|
100
|
|
|
|
863
|
return $self->{SEQIDX} = [] if (!defined $self->{SEQIDX}); |
237
|
238
|
|
|
|
|
747
|
return $self->{SEQIDX}; |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
sub CURSOR { |
241
|
62
|
|
|
62
|
0
|
103
|
my $self = shift; |
242
|
62
|
|
|
|
|
141
|
return \$self->{CURSOR}; |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
sub TIEHASH { |
246
|
11
|
|
|
11
|
|
108401
|
my $class = shift; |
247
|
11
|
|
|
|
|
58
|
my ($file, $flags, $mode, $index, $keep) = @_; |
248
|
11
|
|
100
|
|
|
77
|
$flags //= O_CREAT|O_RDWR; |
249
|
11
|
|
|
|
|
80
|
my $self = {}; |
250
|
11
|
|
|
|
|
46
|
bless($self, $class); |
251
|
|
|
|
|
|
|
# allow $mode to be skipped |
252
|
11
|
50
|
|
|
|
72
|
if (ref($mode) =~ /INFO$/) { # it's the index type |
253
|
0
|
|
|
|
|
0
|
$index = $mode; |
254
|
0
|
|
|
|
|
0
|
$mode = 0644; |
255
|
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
|
#defaults |
257
|
11
|
|
100
|
|
|
61
|
$mode ||= 0644; |
258
|
11
|
|
66
|
|
|
303
|
$index ||= $DB_HASH; |
259
|
11
|
50
|
33
|
|
|
152
|
unless (defined $index and ref($index) =~ /INFO$/) { |
260
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": Index type selector must be a HASHINFO, BTREEINFO, or RECNOINFO object"); |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
|
263
|
11
|
|
|
|
|
411
|
$self->{ref} = 'HASH'; |
264
|
11
|
|
|
|
|
47
|
$self->{index} = $index; |
265
|
11
|
|
|
|
|
43
|
$self->{pending} = 0; |
266
|
11
|
|
|
|
|
37
|
my ($infix,$fh); |
267
|
|
|
|
|
|
|
# db file handling |
268
|
11
|
100
|
|
|
|
49
|
if ($file) { |
269
|
|
|
|
|
|
|
# you'll love this... |
270
|
8
|
|
|
|
|
23
|
my $setmode; |
271
|
8
|
|
|
|
|
31
|
for ($flags) { |
272
|
8
|
100
|
|
|
|
46
|
$_ eq 'O_SVWST' && do { #bullsith kludge |
273
|
1
|
|
|
|
|
6
|
$_ = 514; |
274
|
|
|
|
|
|
|
}; |
275
|
8
|
100
|
|
|
|
43
|
($_ & O_CREAT) && do { |
276
|
6
|
100
|
|
|
|
123
|
$setmode = 1 if ! -e $file; |
277
|
6
|
100
|
|
|
|
50
|
$infix = (-e $file ? '<' : '>'); |
278
|
|
|
|
|
|
|
}; |
279
|
8
|
50
|
|
|
|
39
|
($_ & O_RDWR) && do { |
280
|
8
|
100
|
|
|
|
44
|
$infix = '+'.($infix ? $infix : '<'); |
281
|
|
|
|
|
|
|
}; |
282
|
8
|
100
|
|
|
|
44
|
($_ & O_TRUNC) && do { |
283
|
1
|
|
|
|
|
5
|
$infix = '>'; |
284
|
|
|
|
|
|
|
}; |
285
|
8
|
|
|
|
|
20
|
do { # O_RDONLY |
286
|
8
|
50
|
|
|
|
43
|
$infix = '<' unless $infix; |
287
|
|
|
|
|
|
|
}; |
288
|
|
|
|
|
|
|
} |
289
|
8
|
50
|
|
|
|
639
|
open($fh, $infix, $file) or croak(__PACKAGE__.": Can't open db file: $!"); |
290
|
8
|
100
|
|
|
|
117
|
chmod $mode, $file if $setmode; |
291
|
|
|
|
|
|
|
# if file explicitly specified, but keep is not, |
292
|
|
|
|
|
|
|
# retain file at destroy... |
293
|
8
|
100
|
|
|
|
49
|
$keep = 1 if !defined $keep; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
else { |
296
|
|
|
|
|
|
|
# if no file specified, use a temp file... |
297
|
3
|
|
|
|
|
20
|
($fh, $file) = tempfile(EXLOCK => 0); |
298
|
|
|
|
|
|
|
# if keep not explicitly specified, |
299
|
|
|
|
|
|
|
# remove the tempfile at destroy... |
300
|
3
|
50
|
|
|
|
1706
|
$keep = 0 if !defined $keep; |
301
|
|
|
|
|
|
|
} |
302
|
11
|
|
|
|
|
94
|
$self->file($file); |
303
|
11
|
|
|
|
|
85
|
$self->_fh($fh); |
304
|
11
|
|
|
|
|
65
|
$self->keep($keep); |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
# create SQL statements |
307
|
|
|
|
|
|
|
my $hash_tbl = sub { |
308
|
11
|
|
|
11
|
|
40
|
my $col = shift; |
309
|
11
|
|
100
|
|
|
278
|
$col ||= 'nocase'; |
310
|
11
|
|
|
|
|
311
|
return <
|
311
|
|
|
|
|
|
|
( |
312
|
|
|
|
|
|
|
id blob collate $col, |
313
|
|
|
|
|
|
|
obj blob not null, |
314
|
|
|
|
|
|
|
pk integer primary key autoincrement |
315
|
|
|
|
|
|
|
); |
316
|
|
|
|
|
|
|
END |
317
|
11
|
|
|
|
|
97
|
}; |
318
|
11
|
|
|
|
|
41
|
my $create_idx = <
|
319
|
|
|
|
|
|
|
CREATE INDEX IF NOT EXISTS id_idx ON hash ( id, pk ); |
320
|
|
|
|
|
|
|
END |
321
|
11
|
|
|
|
|
53
|
my $dbh = DBI->connect("DBI:SQLite:dbname=".$self->file,"","", |
322
|
|
|
|
|
|
|
{RaiseError => 1, AutoCommit => 0}); |
323
|
11
|
|
|
|
|
22421
|
$self->dbh( $dbh ); |
324
|
|
|
|
|
|
|
# pragmata inspired by Bio::DB::SeqFeature::Store::DBI::SQLite |
325
|
|
|
|
|
|
|
# $dbh->do("PRAGMA synchronous = OFF"); |
326
|
11
|
|
|
|
|
100
|
$dbh->do("PRAGMA temp_store = MEMORY"); |
327
|
11
|
|
50
|
|
|
5075
|
$dbh->do("PRAGMA cache_size = ".($index->{cachesize} || 20000)); |
328
|
|
|
|
|
|
|
|
329
|
11
|
|
|
|
|
1450
|
for ($index->{'type'}) { |
330
|
11
|
|
100
|
|
|
204
|
my $flags = $index->{flags} || 0; |
331
|
11
|
50
|
|
|
|
52
|
!defined && do { |
332
|
0
|
|
|
|
|
0
|
$self->dbh->do("CREATE TABLE IF NOT EXISTS hash $hash_tbl"); |
333
|
0
|
|
|
|
|
0
|
last; |
334
|
|
|
|
|
|
|
}; |
335
|
11
|
100
|
|
|
|
52
|
$_ eq 'BINARY' && do { |
336
|
4
|
|
|
|
|
13
|
my $col = 'nocase'; |
337
|
4
|
100
|
|
|
|
20
|
if (ref($index->{'compare'}) eq 'CODE') { |
338
|
2
|
|
|
|
|
10
|
$self->dbh->func( 'usr', $index->{'compare'}, "create_collation"); |
339
|
2
|
|
|
|
|
94
|
$col = 'usr'; |
340
|
|
|
|
|
|
|
} |
341
|
4
|
100
|
|
|
|
22
|
if ($flags & R_DUP ) { |
342
|
3
|
|
|
|
|
17
|
$self->dup(1); |
343
|
3
|
|
|
|
|
12
|
$self->dbh->do("CREATE TABLE IF NOT EXISTS hash ".$hash_tbl->($col)); |
344
|
3
|
|
|
|
|
1392
|
$self->dbh->do($create_idx); |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
else { |
347
|
1
|
|
|
|
|
15
|
$self->dup(0); |
348
|
1
|
|
|
|
|
6
|
$self->dbh->do("CREATE TABLE IF NOT EXISTS hash ".$hash_tbl->($col)); |
349
|
1
|
|
|
|
|
457
|
$self->dbh->do($create_idx); |
350
|
|
|
|
|
|
|
} |
351
|
4
|
|
|
|
|
951
|
last; |
352
|
|
|
|
|
|
|
}; |
353
|
7
|
50
|
|
|
|
36
|
$_ eq 'HASH' && do { |
354
|
7
|
|
|
|
|
33
|
$self->dbh->do("CREATE TABLE IF NOT EXISTS hash ".$hash_tbl->()); |
355
|
7
|
|
|
|
|
2170
|
last; |
356
|
|
|
|
|
|
|
}; |
357
|
0
|
0
|
|
|
|
0
|
$_ eq 'RECNO' && do { |
358
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": \$DB_RECNO is not meaningful for tied hashes"); |
359
|
0
|
|
|
|
|
0
|
last; |
360
|
|
|
|
|
|
|
}; |
361
|
0
|
|
|
|
|
0
|
do { |
362
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": Index type not defined or not recognized"); |
363
|
|
|
|
|
|
|
}; |
364
|
|
|
|
|
|
|
} |
365
|
11
|
50
|
100
|
|
|
124
|
$self->_index if ($infix and $infix =~ / and $index->{type} eq 'BINARY'); |
|
|
|
66
|
|
|
|
|
366
|
11
|
|
|
|
|
78
|
$self->commit(1); |
367
|
|
|
|
|
|
|
# barryc fix : fast forward the autokey |
368
|
11
|
|
|
|
|
118
|
my ($sth)=$self->dbh->prepare("select max(pk) from hash"); |
369
|
11
|
|
|
|
|
3215
|
$sth->execute(); |
370
|
11
|
|
|
|
|
196
|
($AUTOPK)=$sth->fetchrow_array(); |
371
|
11
|
|
|
|
|
636
|
return $self; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
sub TIEARRAY { |
375
|
3
|
|
|
3
|
|
6104
|
my $class = shift; |
376
|
3
|
|
|
|
|
19
|
my ($file, $flags, $mode, $index, $keep) = @_; |
377
|
3
|
|
100
|
|
|
23
|
$flags //= O_CREAT|O_RDWR; |
378
|
3
|
|
|
|
|
11
|
my $self = {}; |
379
|
3
|
|
|
|
|
12
|
bless($self, $class); |
380
|
|
|
|
|
|
|
|
381
|
3
|
|
|
|
|
32
|
$self->{ref} = 'ARRAY'; |
382
|
|
|
|
|
|
|
# allow $mode to be skipped |
383
|
3
|
50
|
|
|
|
51
|
if (ref($mode) =~ /INFO$/) { # it's the index type |
384
|
0
|
|
|
|
|
0
|
$index = $mode; |
385
|
0
|
|
|
|
|
0
|
$mode = 0644; |
386
|
|
|
|
|
|
|
} |
387
|
3
|
|
100
|
|
|
39
|
$mode ||= 0644; |
388
|
3
|
|
66
|
|
|
44
|
$index ||= $DB_RECNO; |
389
|
3
|
50
|
33
|
|
|
53
|
unless (defined $index and ref($index) =~ /INFO$/) { |
390
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": Index type selector must be a HASHINFO, BTREEINFO, or RECNOINFO object"); |
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
croak(__PACKAGE__.": Arrays must be tied to type RECNO") unless |
393
|
3
|
50
|
|
|
|
42
|
$index->{type} eq 'RECNO'; |
394
|
3
|
|
|
|
|
13
|
$self->{index} = $index; |
395
|
3
|
|
|
|
|
12
|
$self->{pending} = 0; |
396
|
3
|
|
|
|
|
9
|
my ($infix,$fh); |
397
|
|
|
|
|
|
|
# db file handling |
398
|
3
|
100
|
|
|
|
14
|
if ($file) { |
399
|
1
|
|
|
|
|
3
|
my $setmode; |
400
|
1
|
|
|
|
|
4
|
for ($flags) { |
401
|
1
|
50
|
|
|
|
6
|
$_ eq 'O_SVWST' && do { #bullsith kludge |
402
|
0
|
|
|
|
|
0
|
$_ = 514; |
403
|
|
|
|
|
|
|
}; |
404
|
1
|
50
|
|
|
|
6
|
($_ & O_CREAT) && do { |
405
|
1
|
50
|
|
|
|
14
|
$setmode = 1 if ! -e $file; |
406
|
1
|
50
|
|
|
|
9
|
$infix = (-e $file ? '<' : '>'); |
407
|
|
|
|
|
|
|
}; |
408
|
1
|
50
|
|
|
|
6
|
($_ & O_RDWR) && do { |
409
|
1
|
50
|
|
|
|
5
|
$infix = '+'.($infix ? $infix : '<'); |
410
|
|
|
|
|
|
|
}; |
411
|
1
|
50
|
|
|
|
6
|
($_ & O_TRUNC) && do { |
412
|
0
|
|
|
|
|
0
|
$infix = '>'; |
413
|
|
|
|
|
|
|
}; |
414
|
1
|
|
|
|
|
3
|
do { # O_RDONLY |
415
|
1
|
50
|
|
|
|
4
|
$infix = '<' unless $infix; |
416
|
|
|
|
|
|
|
}; |
417
|
|
|
|
|
|
|
} |
418
|
1
|
50
|
|
|
|
37
|
open($fh, $infix, $file) or croak(__PACKAGE__.": Can't open db file: $!"); |
419
|
1
|
50
|
|
|
|
5
|
chmod $mode, $file if $setmode; |
420
|
|
|
|
|
|
|
# if file explicitly specified, but keep is not, |
421
|
|
|
|
|
|
|
# retain file at destroy... |
422
|
1
|
50
|
|
|
|
6
|
$keep = 1 if !defined $keep; |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
else { |
425
|
|
|
|
|
|
|
# if no file specified, use a temp file... |
426
|
2
|
|
|
|
|
17
|
($fh, $file) = tempfile(EXLOCK => 0); |
427
|
|
|
|
|
|
|
# if keep not explicitly specified, |
428
|
|
|
|
|
|
|
# remove the tempfile at destroy... |
429
|
2
|
50
|
|
|
|
1186
|
$keep = 0 if !defined $keep; |
430
|
|
|
|
|
|
|
} |
431
|
3
|
|
|
|
|
19
|
$self->file($file); |
432
|
3
|
|
|
|
|
18
|
$self->_fh($fh); |
433
|
3
|
|
|
|
|
13
|
$self->keep($keep); |
434
|
|
|
|
|
|
|
|
435
|
3
|
|
|
|
|
8
|
my $arr_tbl = <
|
436
|
|
|
|
|
|
|
( |
437
|
|
|
|
|
|
|
id integer primary key, |
438
|
|
|
|
|
|
|
obj blob not null |
439
|
|
|
|
|
|
|
); |
440
|
|
|
|
|
|
|
END |
441
|
|
|
|
|
|
|
|
442
|
3
|
|
|
|
|
9
|
my $create_idx = <
|
443
|
|
|
|
|
|
|
CREATE INDEX IF NOT EXISTS id_idx ON hash ( id ); |
444
|
|
|
|
|
|
|
END |
445
|
|
|
|
|
|
|
|
446
|
3
|
|
|
|
|
12
|
my $dbh = DBI->connect("dbi:SQLite:dbname=".$self->file,"","", |
447
|
|
|
|
|
|
|
{RaiseError => 1, AutoCommit => 0}); |
448
|
3
|
|
|
|
|
1570
|
$self->dbh( $dbh ); |
449
|
|
|
|
|
|
|
|
450
|
3
|
|
|
|
|
10
|
for ($index->{'type'}) { |
451
|
3
|
|
50
|
|
|
27
|
my $flags = $index->{flags} || 0; |
452
|
3
|
50
|
|
|
|
13
|
$_ eq 'BINARY' && do { |
453
|
0
|
|
|
|
|
0
|
$self->dbh->disconnect; |
454
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": \$DB_BTREE is not meaningful for a tied array"); |
455
|
0
|
|
|
|
|
0
|
last; |
456
|
|
|
|
|
|
|
}; |
457
|
3
|
50
|
|
|
|
23
|
$_ eq 'HASH' && do { |
458
|
0
|
|
|
|
|
0
|
$self->dbh->disconnect; |
459
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": \$DB_HASH is not meaningful for a tied array"); |
460
|
0
|
|
|
|
|
0
|
last; |
461
|
|
|
|
|
|
|
}; |
462
|
3
|
50
|
|
|
|
16
|
$_ eq 'RECNO' && do { |
463
|
3
|
|
|
|
|
16
|
$self->dbh->do("CREATE TABLE IF NOT EXISTS hash $arr_tbl"); |
464
|
3
|
|
|
|
|
2118
|
$self->dbh->do($create_idx); |
465
|
3
|
|
|
|
|
547
|
my $r = $self->dbh->selectall_arrayref("select * from hash"); |
466
|
3
|
|
|
|
|
259
|
for (@$r) { |
467
|
3
|
|
|
|
|
7
|
push @{$self->SEQIDX},$$_[0]; |
|
3
|
|
|
|
|
10
|
|
468
|
|
|
|
|
|
|
} |
469
|
3
|
|
|
|
|
14
|
last; |
470
|
|
|
|
|
|
|
}; |
471
|
0
|
|
|
|
|
0
|
do { |
472
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": Index type not defined or not recognized"); |
473
|
|
|
|
|
|
|
}; |
474
|
|
|
|
|
|
|
} |
475
|
3
|
|
|
|
|
21
|
$self->commit(1); |
476
|
3
|
|
|
|
|
63
|
return $self; |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
# common methods for hashes and arrays |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
sub FETCH { |
482
|
60
|
|
|
60
|
|
678
|
my $self = shift; |
483
|
60
|
|
|
|
|
131
|
my $key = shift; |
484
|
60
|
|
|
|
|
99
|
my $fkey; |
485
|
60
|
50
|
|
|
|
152
|
return unless $self->dbh; |
486
|
60
|
|
|
|
|
210
|
$self->commit; |
487
|
60
|
100
|
66
|
|
|
248
|
if (!$self->{ref} or $self->ref eq 'HASH') { |
|
|
50
|
|
|
|
|
|
488
|
35
|
|
|
|
|
91
|
local $_ = $key; |
489
|
35
|
|
|
|
|
123
|
$self->_store_key_filter; |
490
|
35
|
|
|
|
|
297
|
$self->get_sth->execute($_); # fetches on column 'id' |
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
elsif ($self->ref eq 'ARRAY') { |
493
|
25
|
100
|
|
|
|
41
|
if (defined ${$self->SEQIDX}[$key]) { |
|
25
|
|
|
|
|
53
|
|
494
|
24
|
|
|
|
|
162
|
$self->get_sth->execute($self->get_idx($key)); |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
else { |
497
|
1
|
|
|
|
|
5
|
$self->_last_pk(undef); |
498
|
1
|
|
|
|
|
1
|
return undef; |
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
else { # type not recognized |
502
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": tied type not recognized"); |
503
|
|
|
|
|
|
|
} |
504
|
59
|
|
|
|
|
552
|
my $ret = $self->get_sth->fetch; |
505
|
59
|
100
|
|
|
|
287
|
if ($ret) { |
506
|
56
|
|
|
|
|
224
|
$self->_last_pk( $ret->[1] ); # store the returned pk |
507
|
56
|
|
|
|
|
150
|
$ret->[0] =~ s{}{'}g; |
508
|
56
|
|
|
|
|
120
|
$ret->[0] =~ s{}{"}g; |
509
|
56
|
|
|
|
|
143
|
local $_ = $ret->[0]; |
510
|
56
|
|
|
|
|
195
|
$self->_fetch_value_filter; |
511
|
56
|
|
|
|
|
422
|
return $_; # always returns the object |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
else { |
514
|
3
|
|
|
|
|
18
|
$self->_last_pk( undef ); # fail in pk |
515
|
3
|
|
|
|
|
12
|
return $ret; |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
sub STORE { |
520
|
49
|
|
|
49
|
|
1011
|
my $self = shift; |
521
|
49
|
|
|
|
|
174
|
my ($key, $value) = @_; |
522
|
49
|
|
|
|
|
114
|
my ($fkey, $fvalue); |
523
|
49
|
50
|
|
|
|
160
|
return unless $self->dbh; |
524
|
|
|
|
|
|
|
{ |
525
|
|
|
|
|
|
|
# filter value |
526
|
49
|
|
|
|
|
118
|
local $_ = $value; |
527
|
49
|
|
|
|
|
199
|
$self->_store_value_filter; |
528
|
49
|
|
|
|
|
269
|
$fvalue = $_; |
529
|
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
{ |
531
|
|
|
|
|
|
|
# filter key |
532
|
49
|
|
|
|
|
141
|
$_ = $key; |
|
49
|
|
|
|
|
135
|
|
|
49
|
|
|
|
|
109
|
|
533
|
49
|
|
|
|
|
381
|
$self->_store_key_filter; |
534
|
49
|
|
|
|
|
161
|
$fkey = $_; |
535
|
|
|
|
|
|
|
} |
536
|
49
|
|
|
|
|
165
|
$fvalue =~ s{'}{}g; |
537
|
49
|
|
|
|
|
114
|
$fvalue =~ s{"}{}g; |
538
|
49
|
|
|
|
|
114
|
my ($pk, $sth); |
539
|
49
|
100
|
66
|
|
|
274
|
if ( !defined $self->{ref} or $self->ref eq 'HASH' ) { |
|
|
50
|
|
|
|
|
|
540
|
36
|
100
|
|
|
|
139
|
if ( $self->dup ) { # allowing duplicates |
541
|
17
|
|
|
|
|
57
|
$pk = $self->_get_pk; |
542
|
17
|
|
|
|
|
397
|
$sth = $self->put_sth; |
543
|
17
|
|
|
|
|
223
|
$sth->bind_param(1,$fkey); |
544
|
17
|
|
|
|
|
111
|
$sth->bind_param(2,$fvalue, SQL_BLOB); |
545
|
17
|
|
|
|
|
77
|
$sth->bind_param(3,$pk); |
546
|
17
|
|
|
|
|
103
|
$self->put_sth->execute(); |
547
|
17
|
|
|
|
|
253
|
push @{$self->SEQIDX}, $pk; |
|
17
|
|
|
|
|
66
|
|
548
|
|
|
|
|
|
|
} |
549
|
|
|
|
|
|
|
else { # no duplicates... |
550
|
|
|
|
|
|
|
#need to check if key is already present |
551
|
19
|
100
|
|
|
|
86
|
if ( $self->EXISTS($key) ) |
552
|
|
|
|
|
|
|
{ |
553
|
1
|
|
|
|
|
13
|
$sth = $self->upd_sth; |
554
|
1
|
|
|
|
|
15
|
$sth->bind_param(1,$fvalue, SQL_BLOB); |
555
|
1
|
|
|
|
|
14
|
$sth->bind_param(2,$key); |
556
|
1
|
|
|
|
|
5
|
$sth->bind_param(3,$self->_last_pk); |
557
|
1
|
|
|
|
|
229
|
$sth->execute(); |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
else { |
560
|
18
|
|
|
|
|
105
|
$pk = $self->_get_pk; |
561
|
18
|
|
|
|
|
169
|
$sth = $self->put_sth; |
562
|
18
|
|
|
|
|
175
|
$sth->bind_param(1,$fkey); |
563
|
18
|
|
|
|
|
130
|
$sth->bind_param(2,$fvalue, SQL_BLOB); |
564
|
18
|
|
|
|
|
83
|
$sth->bind_param(3,$pk); |
565
|
18
|
|
|
|
|
1324
|
$sth->execute(); |
566
|
18
|
|
|
|
|
194
|
push @{$self->SEQIDX}, $pk; |
|
18
|
|
|
|
|
86
|
|
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
} |
569
|
36
|
|
|
|
|
258
|
$self->{_stale} = 1; |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
elsif ( $self->ref eq 'ARRAY' ) { |
572
|
|
|
|
|
|
|
# need to check if the key is already present |
573
|
13
|
100
|
|
|
|
27
|
if (!defined ${$self->SEQIDX}[$key] ) { |
|
13
|
|
|
|
|
34
|
|
574
|
12
|
|
|
|
|
83
|
$self->put_sth->execute($self->get_idx($key), $fvalue); |
575
|
|
|
|
|
|
|
} |
576
|
|
|
|
|
|
|
else { |
577
|
1
|
|
|
|
|
31
|
$self->upd_sth->execute($fvalue,$self->get_idx($key)); |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
} |
580
|
49
|
|
|
|
|
153
|
++$self->{pending}; |
581
|
49
|
|
|
|
|
388
|
$value; |
582
|
|
|
|
|
|
|
} |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
sub DELETE { |
585
|
3
|
|
|
3
|
|
12
|
my $self = shift; |
586
|
3
|
|
|
|
|
9
|
my $key = shift; |
587
|
3
|
50
|
|
|
|
14
|
return unless $self->dbh; |
588
|
3
|
|
|
|
|
7
|
my $fkey; |
589
|
|
|
|
|
|
|
{ # filter key |
590
|
3
|
|
|
|
|
8
|
local $_ = $key; |
|
3
|
|
|
|
|
7
|
|
591
|
3
|
|
|
|
|
16
|
$self->_store_key_filter; |
592
|
3
|
|
|
|
|
8
|
$fkey = $_; |
593
|
|
|
|
|
|
|
} |
594
|
3
|
50
|
66
|
|
|
15
|
$self->_reindex if ($self->index->{type} eq 'BINARY' and $self->_index_is_stale); |
595
|
3
|
|
|
|
|
8
|
my $oldval; |
596
|
3
|
100
|
66
|
|
|
12
|
if (!$self->ref or $self->ref eq 'HASH') { |
|
|
50
|
|
|
|
|
|
597
|
2
|
50
|
|
|
|
13
|
return unless $self->get_sth->execute($fkey); |
598
|
2
|
|
|
|
|
16
|
my $ret = $self->get_sth->fetch; |
599
|
2
|
|
|
|
|
10
|
$oldval = $ret->[0]; |
600
|
2
|
|
|
|
|
35
|
$self->del_sth->execute($fkey); # del on id |
601
|
|
|
|
|
|
|
# update the sequential side |
602
|
2
|
50
|
|
|
|
14
|
if ($ret->[1]) { |
603
|
2
|
|
|
|
|
4
|
delete ${$self->SEQIDX}[_find_idx($ret->[1],$self->SEQIDX)]; |
|
2
|
|
|
|
|
9
|
|
604
|
|
|
|
|
|
|
} |
605
|
|
|
|
|
|
|
} |
606
|
|
|
|
|
|
|
elsif ($self->ref eq 'ARRAY') { |
607
|
1
|
|
|
|
|
5
|
my $SEQIDX = $self->SEQIDX; |
608
|
1
|
50
|
|
|
|
6
|
if ($$SEQIDX[$key]) { |
609
|
1
|
|
|
|
|
6
|
$oldval = $self->FETCH($$SEQIDX[$key]); |
610
|
|
|
|
|
|
|
# $self->dbh->do("DELETE FROM hash WHERE id = '$$SEQIDX[$key]'"); |
611
|
1
|
|
|
|
|
6
|
$self->del_sth->execute($$SEQIDX[$key]); # del on id |
612
|
1
|
|
|
|
|
11
|
$self->rm_idx($key); |
613
|
|
|
|
|
|
|
} |
614
|
|
|
|
|
|
|
} |
615
|
|
|
|
|
|
|
else { |
616
|
0
|
|
|
|
|
0
|
croak( __PACKAGE__.": tied type not recognized" ); |
617
|
|
|
|
|
|
|
} |
618
|
3
|
|
|
|
|
10
|
++$self->{pending}; |
619
|
3
|
|
|
|
|
9
|
$_ = $oldval; |
620
|
3
|
|
|
|
|
12
|
$self->_fetch_value_filter; |
621
|
3
|
|
|
|
|
28
|
return $_; |
622
|
|
|
|
|
|
|
} |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
sub EXISTS { |
625
|
25
|
|
|
25
|
|
121
|
my $self = shift; |
626
|
25
|
|
|
|
|
91
|
my $key = shift; |
627
|
25
|
50
|
|
|
|
76
|
return unless $self->dbh; |
628
|
|
|
|
|
|
|
|
629
|
25
|
|
|
|
|
116
|
$self->commit; |
630
|
25
|
50
|
33
|
|
|
70
|
if (!$self->ref or $self->ref eq 'HASH') { |
|
|
0
|
|
|
|
|
|
631
|
25
|
|
|
|
|
72
|
local $_ = $key; |
632
|
25
|
|
|
|
|
173
|
$self->_store_key_filter; |
633
|
25
|
|
|
|
|
278
|
$self->get_sth->execute($_); |
634
|
25
|
|
|
|
|
188
|
my $ret = $self->get_sth->fetch; |
635
|
25
|
100
|
|
|
|
157
|
return $self->_last_pk(defined($ret) ? $ret->[1] : undef); |
636
|
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
|
elsif ($self->ref eq 'ARRAY') { |
638
|
0
|
|
|
|
|
0
|
return $self->_last_pk(${$self->SEQIDX}[$key]); |
|
0
|
|
|
|
|
0
|
|
639
|
|
|
|
|
|
|
} |
640
|
|
|
|
|
|
|
else { |
641
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": tied type not recognized"); |
642
|
|
|
|
|
|
|
} |
643
|
|
|
|
|
|
|
} |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
sub CLEAR { |
646
|
2
|
|
|
2
|
|
8
|
my $self = shift; |
647
|
2
|
50
|
|
|
|
14
|
return unless $self->dbh; |
648
|
2
|
|
|
|
|
11
|
$self->dbh->commit; |
649
|
2
|
|
|
|
|
10
|
my $sth = $self->dbh->prepare("DELETE FROM hash"); |
650
|
2
|
|
|
|
|
752
|
$sth->execute; |
651
|
2
|
|
|
|
|
16
|
$self->dbh->commit; |
652
|
2
|
|
|
|
|
28
|
@{$self->SEQIDX} = (); |
|
2
|
|
|
|
|
31
|
|
653
|
2
|
|
|
|
|
117
|
return 1; |
654
|
|
|
|
|
|
|
} |
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
# hash methods |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
sub FIRSTKEY { |
659
|
6
|
|
|
6
|
|
390
|
my $self = shift; |
660
|
6
|
50
|
|
|
|
30
|
return unless $self->dbh; |
661
|
6
|
|
|
|
|
34
|
$self->commit; |
662
|
6
|
50
|
33
|
|
|
37
|
return if ($self->{ref} and $self->ref ne 'HASH'); |
663
|
6
|
|
|
|
|
23
|
my $ids = $self->dbh->selectall_arrayref("SELECT id FROM hash"); |
664
|
6
|
50
|
|
|
|
870
|
return unless $ids; |
665
|
6
|
|
|
|
|
25
|
$ids = [ map { $_->[0] } @$ids ]; |
|
27
|
|
|
|
|
98
|
|
666
|
|
|
|
|
|
|
{ # filter keys |
667
|
6
|
|
|
|
|
19
|
$self->_fetch_key_filter for (@$ids); |
|
6
|
|
|
|
|
45
|
|
668
|
|
|
|
|
|
|
} |
669
|
6
|
|
|
|
|
35
|
return $self->_keys($ids); |
670
|
|
|
|
|
|
|
} |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
sub NEXTKEY { |
673
|
27
|
|
|
27
|
|
87
|
my $self = shift; |
674
|
27
|
|
|
|
|
53
|
my $lastkey = shift; |
675
|
27
|
50
|
|
|
|
67
|
return unless $self->dbh; |
676
|
27
|
50
|
33
|
|
|
115
|
return if ($self->{ref} and $self->ref ne 'HASH'); |
677
|
27
|
|
|
|
|
83
|
return $self->_keys; |
678
|
|
|
|
|
|
|
} |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
# array methods |
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
sub FETCHSIZE { |
683
|
25
|
|
|
25
|
|
1339
|
my $self = shift; |
684
|
25
|
50
|
|
|
|
57
|
return unless $self->dbh; |
685
|
25
|
50
|
33
|
|
|
99
|
return if (!$self->{ref} or $self->ref ne 'ARRAY'); |
686
|
25
|
|
|
|
|
76
|
$self->len; |
687
|
|
|
|
|
|
|
} |
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
sub STORESIZE { |
690
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
691
|
0
|
|
|
|
|
0
|
my $count = shift; |
692
|
0
|
0
|
|
|
|
0
|
return unless $self->dbh; |
693
|
0
|
0
|
0
|
|
|
0
|
return if (!$self->ref or $self->ref ne 'ARRAY'); |
694
|
0
|
0
|
|
|
|
0
|
if ($count > $self->len) { |
|
|
0
|
|
|
|
|
|
695
|
0
|
|
|
|
|
0
|
foreach ($count - $self->len .. $count) { |
696
|
0
|
|
|
|
|
0
|
$self->STORE($_, ''); |
697
|
|
|
|
|
|
|
} |
698
|
|
|
|
|
|
|
} |
699
|
|
|
|
|
|
|
elsif ($count < $self->len) { |
700
|
0
|
|
|
|
|
0
|
foreach (0 .. $self->len - $count - 2) { |
701
|
0
|
|
|
|
|
0
|
$self->POP(); |
702
|
|
|
|
|
|
|
} |
703
|
|
|
|
|
|
|
} |
704
|
|
|
|
|
|
|
} |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
# EXTEND is no-op |
707
|
|
|
|
|
|
|
sub EXTEND { |
708
|
2
|
|
|
2
|
|
9
|
my $self = shift; |
709
|
2
|
|
|
|
|
7
|
my $count = shift; |
710
|
2
|
|
|
|
|
21
|
return; |
711
|
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
sub POP { |
714
|
3
|
|
|
3
|
|
12
|
my $self = shift; |
715
|
3
|
50
|
|
|
|
9
|
return unless $self->dbh; |
716
|
3
|
|
|
|
|
10
|
$self->commit; |
717
|
3
|
50
|
33
|
|
|
16
|
return if (!$self->{ref} or $self->ref ne 'ARRAY'); |
718
|
3
|
|
|
|
|
18
|
$self->get_sth->execute($self->get_idx($self->len-1)); |
719
|
3
|
|
|
|
|
18
|
my $ret = $self->get_sth->fetch; |
720
|
|
|
|
|
|
|
# $self->dbh->do("DELETE FROM hash WHERE id = ".$self->get_idx($self->len-1)); |
721
|
3
|
|
|
|
|
20
|
$self->del_sth->execute($self->get_idx($self->len-1)); |
722
|
|
|
|
|
|
|
# bookkeeping |
723
|
3
|
|
|
|
|
11
|
$self->rm_idx($self->len-1); |
724
|
3
|
50
|
|
|
|
19
|
return defined $ret ? $ret->[0] : $ret; |
725
|
|
|
|
|
|
|
} |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
sub PUSH { |
728
|
2
|
|
|
2
|
|
7
|
my $self = shift; |
729
|
2
|
|
|
|
|
7
|
my @values = @_; |
730
|
2
|
50
|
|
|
|
6
|
return unless $self->dbh; |
731
|
2
|
50
|
33
|
|
|
11
|
return if (!$self->{ref} or $self->ref ne 'ARRAY'); |
732
|
2
|
|
|
|
|
4
|
my $ret = @values; |
733
|
2
|
|
|
|
|
8
|
my $beg = $self->len; |
734
|
2
|
|
|
|
|
7
|
my $end = $self->len + @values - 1; |
735
|
2
|
|
|
|
|
7
|
for my $i ($beg..$end) { |
736
|
4
|
|
|
|
|
31
|
$self->put_sth->execute($self->get_idx($i), shift @values); |
737
|
|
|
|
|
|
|
} |
738
|
2
|
|
|
|
|
7
|
++$self->{pending}; |
739
|
2
|
|
|
|
|
10
|
return $ret; |
740
|
|
|
|
|
|
|
} |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
sub SHIFT { |
743
|
3
|
|
|
3
|
|
12
|
my $self = shift; |
744
|
3
|
50
|
|
|
|
9
|
return unless $self->dbh; |
745
|
3
|
|
|
|
|
10
|
$self->commit; |
746
|
3
|
50
|
33
|
|
|
13
|
return if (!$self->{ref} or $self->ref ne 'ARRAY'); |
747
|
3
|
|
|
|
|
16
|
$self->get_sth->execute( $self->get_idx(0) ); |
748
|
3
|
|
|
|
|
20
|
my $ret = $self->get_sth->fetch; |
749
|
3
|
|
|
|
|
17
|
$self->del_sth->execute($self->get_idx(0)); |
750
|
|
|
|
|
|
|
# bookkeeping |
751
|
3
|
|
|
|
|
30
|
$self->shift_idx; |
752
|
3
|
|
33
|
|
|
16
|
$_ = $ret && $ret->[0]; |
753
|
3
|
|
|
|
|
9
|
$self->_fetch_value_filter; |
754
|
3
|
|
|
|
|
12
|
return $_; |
755
|
|
|
|
|
|
|
} |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
sub UNSHIFT { |
758
|
2
|
|
|
2
|
|
7
|
my $self = shift; |
759
|
2
|
|
|
|
|
6
|
my @values = @_; |
760
|
2
|
50
|
33
|
|
|
16
|
return if (!$self->{ref} or $self->ref ne 'ARRAY'); |
761
|
2
|
|
|
|
|
5
|
my $n = @values; |
762
|
2
|
|
|
|
|
11
|
$self->_store_value_filter for @values; |
763
|
2
|
50
|
|
|
|
7
|
return unless $self->dbh; |
764
|
2
|
|
|
|
|
17
|
for ($self->unshift_idx($n)) { |
765
|
3
|
|
|
|
|
20
|
$self->put_sth->execute($_,shift @values); |
766
|
|
|
|
|
|
|
} |
767
|
2
|
|
|
|
|
10
|
++$self->{pending}; |
768
|
2
|
|
|
|
|
9
|
return $n; |
769
|
|
|
|
|
|
|
} |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
sub SPLICE { |
772
|
1
|
|
|
1
|
|
664
|
my $self = shift; |
773
|
1
|
|
50
|
|
|
6
|
my $offset = shift || 0; |
774
|
1
|
|
33
|
|
|
7
|
my $length = shift || $self->FETCHSIZE() - $offset; |
775
|
1
|
|
|
|
|
5
|
my @list = @_; |
776
|
1
|
|
|
|
|
5
|
my $SEQIDX = $self->SEQIDX; |
777
|
1
|
|
|
|
|
6
|
$self->_wring_SEQIDX; |
778
|
1
|
|
|
|
|
6
|
my @pk = map { $self->get_idx($_)} ($offset..$offset+$length-1); |
|
2
|
|
|
|
|
7
|
|
779
|
1
|
|
|
|
|
2
|
my @ret; |
780
|
1
|
|
|
|
|
4
|
for (@pk) { |
781
|
2
|
|
|
|
|
16
|
$self->get_sth->execute($_); |
782
|
2
|
|
|
|
|
7
|
push @ret, ${$self->get_sth->fetch}[0]; |
|
2
|
|
|
|
|
16
|
|
783
|
2
|
|
|
|
|
17
|
$self->del_sth->execute($_); |
784
|
|
|
|
|
|
|
} |
785
|
1
|
|
|
|
|
7
|
my @new_idx = map { $AUTOKEY++ } @list; |
|
3
|
|
|
|
|
12
|
|
786
|
1
|
|
|
|
|
7
|
splice( @$SEQIDX, $offset, $length, @new_idx ); |
787
|
1
|
|
|
|
|
12
|
$self->put_sth->execute($_, shift @list) for @new_idx; |
788
|
1
|
|
|
|
|
9
|
$self->_fetch_value_filter for @ret; |
789
|
1
|
|
|
|
|
14
|
return @ret; |
790
|
|
|
|
|
|
|
} |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
# destructors |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
sub UNTIE { |
795
|
8
|
|
|
8
|
|
988
|
my $self = shift; |
796
|
8
|
|
|
|
|
19
|
my $count = shift; |
797
|
|
|
|
|
|
|
|
798
|
8
|
50
|
|
|
|
54
|
croak( __PACKAGE__.": untie attempted while $count inner references still exist" ) if ($count);} |
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
sub DESTROY { |
801
|
14
|
|
|
14
|
|
2841
|
my $self = shift; |
802
|
14
|
|
|
|
|
62
|
$self->dbh->commit; #'hard' commit |
803
|
14
|
|
|
|
|
209
|
my $tbl = $STMT{$self->ref}; |
804
|
|
|
|
|
|
|
# finish and destroy stmt handles |
805
|
14
|
|
|
|
|
135
|
for ( keys %$tbl ) { |
806
|
145
|
100
|
|
|
|
804
|
$self->{$_."_sth"}->finish if $self->{$_."_sth"}; |
807
|
145
|
|
|
|
|
1062
|
undef $self->{$_."_sth"}; |
808
|
|
|
|
|
|
|
} |
809
|
|
|
|
|
|
|
# disconnect |
810
|
14
|
50
|
|
|
|
186
|
croak($self->dbh->errstr) unless $self->dbh->disconnect; |
811
|
14
|
|
|
|
|
180
|
$self->{dbh}->DESTROY; |
812
|
14
|
|
|
|
|
712
|
undef $self->{dbh}; |
813
|
|
|
|
|
|
|
# remove file if nec |
814
|
14
|
50
|
|
|
|
103
|
$self->_fh->close() if $self->_fh; |
815
|
14
|
100
|
|
|
|
402
|
if (-e $self->file) { |
816
|
13
|
|
|
|
|
170
|
local $!; |
817
|
13
|
100
|
66
|
|
|
75
|
unlink $self->file if (!$self->keep && $self->_fh); |
818
|
13
|
50
|
|
|
|
116
|
$! && carp(__PACKAGE__.": unlink issue: $!"); |
819
|
|
|
|
|
|
|
} |
820
|
14
|
|
|
|
|
48
|
undef $self; |
821
|
14
|
|
|
|
|
551
|
1; |
822
|
|
|
|
|
|
|
} |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
# dbm filter storage hooks |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
sub filter_store_key { |
827
|
4
|
|
|
4
|
0
|
190
|
my $self = shift; |
828
|
4
|
|
|
|
|
10
|
my $code = shift; |
829
|
|
|
|
|
|
|
|
830
|
4
|
50
|
66
|
|
|
31
|
unless (!defined($code) or ref($code) eq 'CODE') { |
831
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__."::filter_store_key requires a coderef argument"); |
832
|
|
|
|
|
|
|
} |
833
|
4
|
|
|
|
|
19
|
$self->_store_key_filter($code); |
834
|
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
}; |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
sub filter_store_value { |
838
|
2
|
|
|
2
|
0
|
25
|
my $self = shift; |
839
|
2
|
|
|
|
|
6
|
my $code = shift; |
840
|
2
|
50
|
33
|
|
|
22
|
unless (!defined($code) or ref($code) eq 'CODE') { |
841
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__."::filter_store_value requires a coderef argument"); |
842
|
|
|
|
|
|
|
} |
843
|
2
|
|
|
|
|
12
|
$self->_store_value_filter($code); |
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
}; |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
sub filter_fetch_key { |
848
|
3
|
|
|
3
|
0
|
1161
|
my $self = shift; |
849
|
3
|
|
|
|
|
8
|
my $code = shift; |
850
|
3
|
100
|
66
|
|
|
22
|
unless (!defined($code) or ref($code) eq 'CODE') { |
851
|
1
|
|
|
|
|
22
|
croak(__PACKAGE__."::filter_fetch_key requires a coderef argument"); |
852
|
|
|
|
|
|
|
} |
853
|
2
|
|
|
|
|
10
|
$self->_fetch_key_filter($code); |
854
|
|
|
|
|
|
|
}; |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
sub filter_fetch_value { |
857
|
2
|
|
|
2
|
0
|
12
|
my $self = shift; |
858
|
2
|
|
|
|
|
6
|
my $code = shift; |
859
|
2
|
50
|
33
|
|
|
20
|
unless (!defined($code) or ref($code) eq 'CODE') { |
860
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__."::filter_fetch_value requires a coderef argument"); |
861
|
|
|
|
|
|
|
} |
862
|
2
|
|
|
|
|
11
|
$self->_fetch_value_filter($code); |
863
|
|
|
|
|
|
|
}; |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
# filters |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
sub _fetch_key_filter { |
868
|
29
|
|
|
29
|
|
81
|
my $self = shift; |
869
|
29
|
100
|
|
|
|
83
|
if (@_) { |
870
|
2
|
|
|
|
|
10
|
$self->{_fetch_key_filter} = shift; |
871
|
2
|
|
|
|
|
7
|
return 1; |
872
|
|
|
|
|
|
|
} |
873
|
27
|
100
|
|
|
|
95
|
return unless defined $self->{_fetch_key_filter}; |
874
|
6
|
|
|
|
|
13
|
&{$self->{_fetch_key_filter}}; |
|
6
|
|
|
|
|
17
|
|
875
|
|
|
|
|
|
|
}; |
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
sub _fetch_value_filter { |
878
|
66
|
|
|
66
|
|
137
|
my $self = shift; |
879
|
66
|
100
|
|
|
|
170
|
if (@_) { |
880
|
2
|
|
|
|
|
8
|
$self->{_fetch_value_filter} = shift; |
881
|
2
|
|
|
|
|
8
|
return 1; |
882
|
|
|
|
|
|
|
} |
883
|
64
|
100
|
|
|
|
211
|
return unless defined $self->{_fetch_value_filter}; |
884
|
7
|
|
|
|
|
14
|
&{$self->{_fetch_value_filter}}; |
|
7
|
|
|
|
|
26
|
|
885
|
|
|
|
|
|
|
}; |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
sub _store_key_filter { |
888
|
116
|
|
|
116
|
|
230
|
my $self = shift; |
889
|
116
|
100
|
|
|
|
312
|
if (@_) { |
890
|
4
|
|
|
|
|
17
|
$self->{_store_key_filter} = shift; |
891
|
4
|
|
|
|
|
14
|
return 1; |
892
|
|
|
|
|
|
|
} |
893
|
112
|
100
|
|
|
|
493
|
return unless defined $self->{_store_key_filter}; |
894
|
15
|
|
|
|
|
32
|
&{$self->{_store_key_filter}}; |
|
15
|
|
|
|
|
43
|
|
895
|
|
|
|
|
|
|
}; |
896
|
|
|
|
|
|
|
|
897
|
|
|
|
|
|
|
sub _store_value_filter { |
898
|
54
|
|
|
54
|
|
114
|
my $self = shift; |
899
|
54
|
100
|
|
|
|
149
|
if (@_) { |
900
|
2
|
|
|
|
|
7
|
$self->{_store_value_filter} = shift; |
901
|
2
|
|
|
|
|
6
|
return 1; |
902
|
|
|
|
|
|
|
} |
903
|
52
|
100
|
|
|
|
174
|
return unless defined $self->{_store_value_filter}; |
904
|
7
|
|
|
|
|
18
|
&{$self->{_store_value_filter}}; |
|
7
|
|
|
|
|
33
|
|
905
|
|
|
|
|
|
|
}; |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
=head1 Attribute Accessors |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
=head2 file() |
910
|
|
|
|
|
|
|
|
911
|
|
|
|
|
|
|
Title : file |
912
|
|
|
|
|
|
|
Usage : $db->file() |
913
|
|
|
|
|
|
|
Function: filename for the SQLite db |
914
|
|
|
|
|
|
|
Example : |
915
|
|
|
|
|
|
|
Returns : value of file (a scalar) |
916
|
|
|
|
|
|
|
Args : |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
=cut |
919
|
|
|
|
|
|
|
|
920
|
|
|
|
|
|
|
sub file { |
921
|
50
|
|
|
50
|
1
|
187
|
my $self = shift; |
922
|
|
|
|
|
|
|
|
923
|
50
|
100
|
|
|
|
189
|
return $self->{'file'} = shift if @_; |
924
|
36
|
|
|
|
|
1091
|
return $self->{'file'}; |
925
|
|
|
|
|
|
|
} |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
=head2 _fh() |
928
|
|
|
|
|
|
|
|
929
|
|
|
|
|
|
|
Title : _fh |
930
|
|
|
|
|
|
|
Usage : $db->_fh() |
931
|
|
|
|
|
|
|
Function: holds the temp file handle |
932
|
|
|
|
|
|
|
Example : |
933
|
|
|
|
|
|
|
Returns : value of _fh (a scalar) |
934
|
|
|
|
|
|
|
Args : |
935
|
|
|
|
|
|
|
|
936
|
|
|
|
|
|
|
=cut |
937
|
|
|
|
|
|
|
|
938
|
|
|
|
|
|
|
sub _fh { |
939
|
49
|
|
|
49
|
|
124
|
my $self = shift; |
940
|
|
|
|
|
|
|
|
941
|
49
|
100
|
|
|
|
279
|
return $self->{'_fh'} = shift if @_; |
942
|
35
|
|
|
|
|
346
|
return $self->{'_fh'}; |
943
|
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
=head2 keep() |
946
|
|
|
|
|
|
|
|
947
|
|
|
|
|
|
|
Title : keep |
948
|
|
|
|
|
|
|
Usage : $db->keep() |
949
|
|
|
|
|
|
|
Function: flag allows preservation of db file when set |
950
|
|
|
|
|
|
|
Returns : value of keep (a scalar) |
951
|
|
|
|
|
|
|
Args : |
952
|
|
|
|
|
|
|
|
953
|
|
|
|
|
|
|
=cut |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
sub keep { |
956
|
28
|
|
|
28
|
1
|
201
|
my $self = shift; |
957
|
|
|
|
|
|
|
|
958
|
28
|
100
|
|
|
|
124
|
return $self->{'keep'} = shift if @_; |
959
|
13
|
|
|
|
|
91
|
return $self->{'keep'}; |
960
|
|
|
|
|
|
|
} |
961
|
|
|
|
|
|
|
|
962
|
|
|
|
|
|
|
=head2 ref() |
963
|
|
|
|
|
|
|
|
964
|
|
|
|
|
|
|
Title : ref |
965
|
|
|
|
|
|
|
Usage : $db->ref |
966
|
|
|
|
|
|
|
Function: HASH or ARRAY? Find out. |
967
|
|
|
|
|
|
|
Returns : scalar string : 'HASH' or 'ARRAY' |
968
|
|
|
|
|
|
|
Args : none |
969
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
=cut |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
|
973
|
|
|
|
|
|
|
sub ref { |
974
|
1031
|
|
|
1031
|
1
|
1913
|
my $self = shift; |
975
|
1031
|
|
|
|
|
10521
|
return $self->{ref}; |
976
|
|
|
|
|
|
|
} |
977
|
|
|
|
|
|
|
|
978
|
|
|
|
|
|
|
=head2 index() |
979
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
Title : index |
981
|
|
|
|
|
|
|
Usage : $db->index() |
982
|
|
|
|
|
|
|
Function: access the index type structure ($DB_BTREE, $DB_HASH, |
983
|
|
|
|
|
|
|
$DB_RECNO) that initialized this instance |
984
|
|
|
|
|
|
|
Returns : value of index (a hashref) |
985
|
|
|
|
|
|
|
Args : |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
=cut |
988
|
|
|
|
|
|
|
|
989
|
|
|
|
|
|
|
sub index { |
990
|
54
|
|
|
54
|
1
|
93
|
my $self = shift; |
991
|
54
|
|
|
|
|
271
|
return $self->{'index'}; |
992
|
|
|
|
|
|
|
} |
993
|
|
|
|
|
|
|
|
994
|
|
|
|
|
|
|
# =head2 _keys |
995
|
|
|
|
|
|
|
|
996
|
|
|
|
|
|
|
# Title : _keys |
997
|
|
|
|
|
|
|
# Usage : internal |
998
|
|
|
|
|
|
|
# Function: points to a hash to make iterating easy and fun |
999
|
|
|
|
|
|
|
# Example : |
1000
|
|
|
|
|
|
|
# Returns : value of _keys (a hashref) |
1001
|
|
|
|
|
|
|
# Args : on set, an arrayref of scalar keys |
1002
|
|
|
|
|
|
|
|
1003
|
|
|
|
|
|
|
# =cut |
1004
|
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
|
sub _keys { |
1006
|
33
|
|
|
33
|
|
67
|
my $self = shift; |
1007
|
33
|
|
|
|
|
73
|
my $load = shift; |
1008
|
33
|
100
|
|
|
|
77
|
if ($load) { |
1009
|
6
|
|
|
|
|
29
|
$self->{'_keys'} = {}; |
1010
|
6
|
|
|
|
|
28
|
@{$self->{'_keys'}}{ @$load } = (undef) x @$load; |
|
6
|
|
|
|
|
46
|
|
1011
|
6
|
|
|
|
|
511
|
my $a = keys %{$self->{'_keys'}}; #reset each |
|
6
|
|
|
|
|
32
|
|
1012
|
|
|
|
|
|
|
} |
1013
|
33
|
|
|
|
|
63
|
return each %{$self->{'_keys'}}; |
|
33
|
|
|
|
|
264
|
|
1014
|
|
|
|
|
|
|
} |
1015
|
|
|
|
|
|
|
|
1016
|
|
|
|
|
|
|
=head1 BDB API Emulation : random access |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
=head2 get() |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
Title : get |
1021
|
|
|
|
|
|
|
Usage : $db->get($key, $value) |
1022
|
|
|
|
|
|
|
Function: Get value associated with key |
1023
|
|
|
|
|
|
|
Returns : 0 on success, 1 on fail; |
1024
|
|
|
|
|
|
|
value in $value |
1025
|
|
|
|
|
|
|
Args : as in DB_File |
1026
|
|
|
|
|
|
|
|
1027
|
|
|
|
|
|
|
=cut |
1028
|
|
|
|
|
|
|
|
1029
|
|
|
|
|
|
|
sub get { |
1030
|
2
|
|
|
2
|
1
|
8
|
my $self = shift; |
1031
|
2
|
|
|
|
|
8
|
my ($key, $value) = @_; |
1032
|
2
|
50
|
|
|
|
8
|
return unless $self->dbh; |
1033
|
2
|
100
|
|
|
|
7
|
$_[1] = ($self->ref eq 'ARRAY' ? $self->FETCH(${$self->SEQIDX}[$key]) : $self->FETCH($key)); |
|
1
|
|
|
|
|
5
|
|
1034
|
2
|
50
|
|
|
|
16
|
return 0 if defined $_[1]; |
1035
|
0
|
|
|
|
|
0
|
return 1; |
1036
|
|
|
|
|
|
|
} |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
=head2 put() |
1039
|
|
|
|
|
|
|
|
1040
|
|
|
|
|
|
|
Title : put |
1041
|
|
|
|
|
|
|
Usage : $db->put($key, $value, $flags) |
1042
|
|
|
|
|
|
|
Function: Replace a key's value, or |
1043
|
|
|
|
|
|
|
put a key-value pair |
1044
|
|
|
|
|
|
|
Returns : 0 on success, 1 on fail; |
1045
|
|
|
|
|
|
|
value in $value |
1046
|
|
|
|
|
|
|
key in $key if $flags == R_CURSOR |
1047
|
|
|
|
|
|
|
Args : as in DB_File |
1048
|
|
|
|
|
|
|
|
1049
|
|
|
|
|
|
|
=cut |
1050
|
|
|
|
|
|
|
|
1051
|
|
|
|
|
|
|
sub put { |
1052
|
8
|
|
|
8
|
1
|
32
|
my $self = shift; |
1053
|
8
|
|
|
|
|
24
|
my ($key, $value, $flags) = @_; |
1054
|
8
|
50
|
|
|
|
24
|
return unless $self->dbh; |
1055
|
|
|
|
|
|
|
|
1056
|
8
|
|
|
|
|
26
|
my $SEQIDX = $self->SEQIDX; |
1057
|
8
|
|
|
|
|
27
|
my $CURSOR = $self->CURSOR; |
1058
|
8
|
|
|
|
|
30
|
my ($status, $pk, @parms); |
1059
|
8
|
|
|
|
|
0
|
my ($sth, $do_cursor); |
1060
|
8
|
|
|
|
|
23
|
for ($flags) { |
1061
|
8
|
100
|
100
|
|
|
45
|
(!defined || $_ == R_SETCURSOR) && do { # put or upd |
1062
|
5
|
50
|
|
|
|
19
|
if ($self->dup) { # just make a new one |
1063
|
0
|
|
|
|
|
0
|
$pk = $self->_get_pk; |
1064
|
0
|
|
|
|
|
0
|
$sth = $self->put_seq_sth; |
1065
|
|
|
|
|
|
|
$do_cursor = sub { |
1066
|
0
|
|
|
0
|
|
0
|
push @$SEQIDX, $pk; |
1067
|
0
|
0
|
|
|
|
0
|
$$CURSOR = $#$SEQIDX if $flags; |
1068
|
0
|
0
|
|
|
|
0
|
$self->_reindex if $self->index->{type} eq 'BINARY'; |
1069
|
0
|
|
|
|
|
0
|
}; |
1070
|
|
|
|
|
|
|
} |
1071
|
|
|
|
|
|
|
else { |
1072
|
5
|
|
|
|
|
28
|
$self->FETCH($key); |
1073
|
5
|
|
66
|
|
|
15
|
$pk = $self->_last_pk || $self->_get_pk; |
1074
|
5
|
100
|
|
|
|
12
|
$sth = ($self->_last_pk ? |
1075
|
|
|
|
|
|
|
$self->upd_seq_sth : |
1076
|
|
|
|
|
|
|
$self->put_seq_sth); |
1077
|
|
|
|
|
|
|
$do_cursor = sub { |
1078
|
5
|
100
|
|
5
|
|
17
|
push @$SEQIDX, $pk if !$self->_last_pk; |
1079
|
5
|
100
|
|
|
|
17
|
$flags && do { # R_SETCURSOR |
1080
|
2
|
50
|
|
|
|
12
|
if ( $pk = $$SEQIDX[-1] ) { |
1081
|
2
|
|
|
|
|
5
|
$$CURSOR = $#$SEQIDX; |
1082
|
|
|
|
|
|
|
} |
1083
|
|
|
|
|
|
|
else { |
1084
|
0
|
|
|
|
|
0
|
$$CURSOR = _find_idx($pk, $SEQIDX); |
1085
|
|
|
|
|
|
|
}; |
1086
|
2
|
100
|
|
|
|
7
|
$self->_reindex if $self->index->{type} eq 'BINARY'; |
1087
|
|
|
|
|
|
|
}; |
1088
|
5
|
|
|
|
|
45
|
}; |
1089
|
|
|
|
|
|
|
} |
1090
|
5
|
|
|
|
|
12
|
last; |
1091
|
|
|
|
|
|
|
}; |
1092
|
3
|
100
|
|
|
|
9
|
$_ == R_IAFTER && do { |
1093
|
1
|
50
|
|
|
|
4
|
$self->_wring_SEQIDX unless $$SEQIDX[$$CURSOR]; |
1094
|
|
|
|
|
|
|
# duplicate protect |
1095
|
1
|
0
|
33
|
|
|
3
|
return 1 unless ($self->ref eq 'ARRAY') || $self->dup || !$self->EXISTS($key); |
|
|
|
33
|
|
|
|
|
1096
|
|
|
|
|
|
|
croak(__PACKAGE__.": R_IAFTER flag meaningful only for RECNO type") unless |
1097
|
1
|
50
|
|
|
|
3
|
$self->index->{type} eq 'RECNO'; |
1098
|
1
|
|
|
|
|
4
|
$pk = $self->_get_pk; |
1099
|
1
|
|
|
|
|
6
|
$sth = $self->put_seq_sth; |
1100
|
1
|
|
|
|
|
3
|
$_[0] = $$CURSOR+1; |
1101
|
|
|
|
|
|
|
$do_cursor = sub { |
1102
|
1
|
50
|
|
1
|
|
4
|
if ($$CURSOR == $#$SEQIDX) { |
1103
|
1
|
|
|
|
|
3
|
push @$SEQIDX, $pk; |
1104
|
|
|
|
|
|
|
} |
1105
|
|
|
|
|
|
|
else { |
1106
|
0
|
|
|
|
|
0
|
splice(@$SEQIDX,$$CURSOR,0,$pk); |
1107
|
|
|
|
|
|
|
} |
1108
|
1
|
|
|
|
|
6
|
}; |
1109
|
1
|
|
|
|
|
2
|
last; |
1110
|
|
|
|
|
|
|
}; |
1111
|
2
|
100
|
|
|
|
7
|
$_ == R_IBEFORE && do { |
1112
|
1
|
50
|
|
|
|
9
|
$self->_wring_SEQIDX unless $$SEQIDX[$$CURSOR]; |
1113
|
|
|
|
|
|
|
# duplicate protect |
1114
|
1
|
0
|
33
|
|
|
3
|
return 1 unless ($self->ref eq 'ARRAY') || $self->dup || !$self->EXISTS($key); |
|
|
|
33
|
|
|
|
|
1115
|
|
|
|
|
|
|
croak(__PACKAGE__.": R_IBEFORE flag meaningful only for RECNO type") unless |
1116
|
1
|
50
|
|
|
|
4
|
$self->index->{type} eq 'RECNO'; |
1117
|
1
|
|
|
|
|
5
|
$pk = $self->_get_pk; |
1118
|
1
|
|
|
|
|
6
|
$sth = $self->put_seq_sth; |
1119
|
1
|
|
|
|
|
3
|
$_[0] = $$CURSOR; |
1120
|
|
|
|
|
|
|
$do_cursor = sub { |
1121
|
1
|
50
|
|
1
|
|
5
|
if ($$CURSOR) { |
1122
|
0
|
|
|
|
|
0
|
splice(@$SEQIDX,$$CURSOR-1,0,$pk); |
1123
|
|
|
|
|
|
|
} |
1124
|
|
|
|
|
|
|
else { |
1125
|
1
|
|
|
|
|
4
|
unshift(@$SEQIDX, $pk); |
1126
|
|
|
|
|
|
|
} |
1127
|
1
|
|
|
|
|
3
|
$$CURSOR++; # preserve cursor |
1128
|
1
|
|
|
|
|
7
|
}; |
1129
|
1
|
|
|
|
|
4
|
last; |
1130
|
|
|
|
|
|
|
}; |
1131
|
1
|
50
|
|
|
|
4
|
$_ == R_CURSOR && do { # upd only |
1132
|
0
|
0
|
|
|
|
0
|
$self->_wring_SEQIDX unless $$SEQIDX[$$CURSOR]; |
1133
|
|
|
|
|
|
|
# duplicate protect |
1134
|
0
|
0
|
0
|
|
|
0
|
return 1 unless ($self->ref eq 'ARRAY') || $self->dup || !$self->EXISTS($key); |
|
|
|
0
|
|
|
|
|
1135
|
0
|
|
|
|
|
0
|
$pk = $$SEQIDX[$$CURSOR]; |
1136
|
0
|
|
|
|
|
0
|
$sth = $self->upd_seq_sth; |
1137
|
|
|
|
|
|
|
$do_cursor = sub { |
1138
|
0
|
0
|
|
0
|
|
0
|
$self->_reindex if $self->index->{type} eq 'BINARY'; |
1139
|
0
|
|
|
|
|
0
|
}; |
1140
|
0
|
|
|
|
|
0
|
last; |
1141
|
|
|
|
|
|
|
}; |
1142
|
1
|
50
|
|
|
|
3
|
$_ == R_NOOVERWRITE && do { # put only/add to the "end" |
1143
|
|
|
|
|
|
|
#will create a duplicate if $self->dup is set! |
1144
|
1
|
50
|
33
|
|
|
4
|
return 1 unless ($self->ref eq 'ARRAY') || $self->dup || !$self->EXISTS($key); |
|
|
|
33
|
|
|
|
|
1145
|
0
|
|
|
|
|
0
|
$pk = $self->_get_pk; |
1146
|
0
|
|
|
|
|
0
|
$sth = $self->put_seq_sth; |
1147
|
|
|
|
|
|
|
$do_cursor = sub { |
1148
|
0
|
|
|
0
|
|
0
|
push @$SEQIDX, $pk; |
1149
|
0
|
0
|
|
|
|
0
|
$self->_reindex if $self->index->{type} eq 'BINARY'; |
1150
|
0
|
|
|
|
|
0
|
}; |
1151
|
0
|
|
|
|
|
0
|
last; |
1152
|
|
|
|
|
|
|
}; |
1153
|
|
|
|
|
|
|
} |
1154
|
7
|
100
|
|
|
|
15
|
if ($self->ref eq 'ARRAY') { |
1155
|
4
|
|
|
|
|
35
|
$sth->bind_param(1, $value, SQL_BLOB); |
1156
|
4
|
|
|
|
|
16
|
$sth->bind_param(2, $pk); |
1157
|
|
|
|
|
|
|
} |
1158
|
|
|
|
|
|
|
else { |
1159
|
3
|
|
|
|
|
17
|
$sth->bind_param(1, $key); |
1160
|
3
|
|
|
|
|
16
|
$sth->bind_param(2, $value, SQL_BLOB); |
1161
|
3
|
|
|
|
|
8
|
$sth->bind_param(3, $pk); |
1162
|
|
|
|
|
|
|
} |
1163
|
7
|
|
|
|
|
179
|
$status = !$sth->execute; |
1164
|
7
|
50
|
|
|
|
36
|
$do_cursor->() if !$status; |
1165
|
7
|
|
|
|
|
14
|
$self->{pending} = 1; |
1166
|
7
|
100
|
|
|
|
22
|
$self->{_stale} = 0 if $self->index->{type} eq 'BINARY'; |
1167
|
7
|
|
|
|
|
77
|
return $status; |
1168
|
|
|
|
|
|
|
} |
1169
|
|
|
|
|
|
|
|
1170
|
|
|
|
|
|
|
=head2 del() |
1171
|
|
|
|
|
|
|
|
1172
|
|
|
|
|
|
|
Title : del |
1173
|
|
|
|
|
|
|
Usage : $db->del($key) |
1174
|
|
|
|
|
|
|
Function: delete key-value pairs corresponding to $key |
1175
|
|
|
|
|
|
|
Returns : 0 on success, 1 on fail |
1176
|
|
|
|
|
|
|
Args : as in DB_File |
1177
|
|
|
|
|
|
|
|
1178
|
|
|
|
|
|
|
=cut |
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
sub del { |
1181
|
2
|
|
|
2
|
1
|
5
|
my $self = shift; |
1182
|
2
|
|
|
|
|
8
|
my ($key, $flags) = @_; |
1183
|
2
|
50
|
|
|
|
8
|
return unless $self->dbh; |
1184
|
2
|
50
|
66
|
|
|
10
|
$self->_reindex if ($self->index->{type} eq 'BINARY' and $self->_index_is_stale); |
1185
|
2
|
|
|
|
|
5
|
my $SEQIDX = $self->SEQIDX; |
1186
|
2
|
|
|
|
|
8
|
my $CURSOR = $self->CURSOR; |
1187
|
2
|
|
|
|
|
4
|
my $status; |
1188
|
2
|
50
|
|
|
|
6
|
if ($flags eq R_CURSOR) { |
1189
|
2
|
50
|
|
|
|
8
|
_wring_SEQIDX($self->SEQIDX) unless $$SEQIDX[$$CURSOR]; |
1190
|
2
|
|
|
|
|
5
|
my $pk = $$SEQIDX[$$CURSOR]; |
1191
|
2
|
|
|
|
|
18
|
$status = $self->del_seq_sth->execute($pk); |
1192
|
2
|
50
|
|
|
|
12
|
if ($status) { # successful delete |
1193
|
2
|
|
|
|
|
5
|
$$SEQIDX[$$CURSOR] = undef; |
1194
|
2
|
|
|
|
|
13
|
$self->_wring_SEQIDX; |
1195
|
|
|
|
|
|
|
} |
1196
|
2
|
|
|
|
|
3
|
1; |
1197
|
|
|
|
|
|
|
} |
1198
|
|
|
|
|
|
|
else { |
1199
|
|
|
|
|
|
|
# delete all matches |
1200
|
0
|
|
|
|
|
0
|
$status = $self->DELETE($key); |
1201
|
0
|
|
|
|
|
0
|
1; |
1202
|
|
|
|
|
|
|
} |
1203
|
2
|
|
|
|
|
6
|
$self->{_stale} = 1; |
1204
|
2
|
|
|
|
|
5
|
$self->{pending} = 1; |
1205
|
2
|
50
|
|
|
|
11
|
return 0 if $status; |
1206
|
0
|
|
|
|
|
0
|
return 1; |
1207
|
|
|
|
|
|
|
} |
1208
|
|
|
|
|
|
|
|
1209
|
|
|
|
|
|
|
=head1 BDB API Emulation : sequential access |
1210
|
|
|
|
|
|
|
|
1211
|
|
|
|
|
|
|
=head2 seq() |
1212
|
|
|
|
|
|
|
|
1213
|
|
|
|
|
|
|
Title : seq |
1214
|
|
|
|
|
|
|
Usage : $db->seq($key, $value, $flags) |
1215
|
|
|
|
|
|
|
Function: retrieve key-value pairs sequentially, |
1216
|
|
|
|
|
|
|
according to $flags, with partial matching |
1217
|
|
|
|
|
|
|
on $key; see DB_File |
1218
|
|
|
|
|
|
|
Returns : 0 on success, 1 on fail; |
1219
|
|
|
|
|
|
|
key in $key, |
1220
|
|
|
|
|
|
|
value in $value |
1221
|
|
|
|
|
|
|
Args : as in DB_File |
1222
|
|
|
|
|
|
|
|
1223
|
|
|
|
|
|
|
=cut |
1224
|
|
|
|
|
|
|
|
1225
|
|
|
|
|
|
|
sub seq { |
1226
|
34
|
|
|
34
|
1
|
74
|
my $self = shift; |
1227
|
34
|
|
|
|
|
96
|
my ($key, $value, $flags) = @_; |
1228
|
34
|
50
|
|
|
|
93
|
return 1 unless $flags; |
1229
|
34
|
|
|
|
|
123
|
$self->commit; |
1230
|
34
|
|
|
|
|
56
|
my $status; |
1231
|
34
|
100
|
100
|
|
|
75
|
$self->_reindex if ($self->index->{type} eq 'BINARY' and $self->_index_is_stale); |
1232
|
34
|
|
|
|
|
89
|
my $SEQIDX = $self->SEQIDX; |
1233
|
34
|
|
|
|
|
82
|
my $CURSOR = $self->CURSOR; |
1234
|
34
|
|
|
|
|
79
|
for ($flags) { |
1235
|
34
|
100
|
|
|
|
86
|
$_ eq R_CURSOR && do { |
1236
|
6
|
|
|
|
|
13
|
last; |
1237
|
|
|
|
|
|
|
}; |
1238
|
28
|
100
|
|
|
|
138
|
$_ eq R_FIRST && do { |
1239
|
6
|
|
|
|
|
14
|
$$CURSOR = 0; |
1240
|
6
|
|
|
|
|
14
|
last; |
1241
|
|
|
|
|
|
|
}; |
1242
|
22
|
100
|
|
|
|
78
|
$_ eq R_LAST && do { |
1243
|
4
|
|
|
|
|
10
|
$$CURSOR = $#$SEQIDX; |
1244
|
4
|
|
|
|
|
8
|
last; |
1245
|
|
|
|
|
|
|
}; |
1246
|
18
|
100
|
|
|
|
44
|
$_ eq R_NEXT && do { |
1247
|
14
|
100
|
|
|
|
56
|
return 1 if ($$CURSOR >= $#$SEQIDX); |
1248
|
11
|
|
|
|
|
100
|
($$CURSOR)++; |
1249
|
11
|
|
|
|
|
26
|
last; |
1250
|
|
|
|
|
|
|
}; |
1251
|
4
|
50
|
|
|
|
11
|
$_ eq R_PREV && do { |
1252
|
4
|
100
|
|
|
|
24
|
return 1 if $$CURSOR == 0; |
1253
|
2
|
|
|
|
|
5
|
($$CURSOR)--; |
1254
|
2
|
|
|
|
|
4
|
last; |
1255
|
|
|
|
|
|
|
}; |
1256
|
|
|
|
|
|
|
} |
1257
|
29
|
100
|
|
|
|
103
|
$self->_wring_SEQIDX() unless defined $$SEQIDX[$$CURSOR]; |
1258
|
|
|
|
|
|
|
# get by pk, set key and value. |
1259
|
29
|
100
|
100
|
|
|
59
|
if (($flags == R_CURSOR ) && $self->ref eq 'HASH') { |
1260
|
3
|
|
|
|
|
24
|
$status = $self->partial_match($key, $value); |
1261
|
3
|
|
|
|
|
10
|
$_[0] = $key; $_[1] = $value; |
|
3
|
|
|
|
|
8
|
|
1262
|
3
|
|
|
|
|
17
|
return $status; |
1263
|
|
|
|
|
|
|
} |
1264
|
|
|
|
|
|
|
else { |
1265
|
26
|
|
|
|
|
216
|
$self->get_seq_sth->execute($$SEQIDX[$$CURSOR]); |
1266
|
26
|
|
|
|
|
155
|
my $ret = $self->get_seq_sth->fetch; |
1267
|
26
|
100
|
|
|
|
80
|
($_[0], $_[1]) = (($self->ref eq 'ARRAY' ? $$CURSOR : $$ret[0]), $$ret[1]); |
1268
|
|
|
|
|
|
|
} |
1269
|
26
|
|
|
|
|
126
|
return 0; |
1270
|
|
|
|
|
|
|
} |
1271
|
|
|
|
|
|
|
|
1272
|
|
|
|
|
|
|
=head2 sync() |
1273
|
|
|
|
|
|
|
|
1274
|
|
|
|
|
|
|
Title : sync |
1275
|
|
|
|
|
|
|
Usage : $db->sync |
1276
|
|
|
|
|
|
|
Function: stub for BDB sync |
1277
|
|
|
|
|
|
|
Returns : 0 |
1278
|
|
|
|
|
|
|
Args : none |
1279
|
|
|
|
|
|
|
|
1280
|
|
|
|
|
|
|
=cut |
1281
|
|
|
|
|
|
|
|
1282
|
0
|
|
|
0
|
1
|
0
|
sub sync { !shift->commit }; |
1283
|
|
|
|
|
|
|
|
1284
|
|
|
|
|
|
|
=head1 BDB API Emulation : C |
1285
|
|
|
|
|
|
|
|
1286
|
|
|
|
|
|
|
=head2 dup |
1287
|
|
|
|
|
|
|
|
1288
|
|
|
|
|
|
|
Title : dup |
1289
|
|
|
|
|
|
|
Usage : $db->dup() |
1290
|
|
|
|
|
|
|
Function: Get/set flag indicating whether duplicate keys |
1291
|
|
|
|
|
|
|
are preserved |
1292
|
|
|
|
|
|
|
Returns : boolean |
1293
|
|
|
|
|
|
|
Args : [optional] on set, new value (a scalar or undef, optional) |
1294
|
|
|
|
|
|
|
|
1295
|
|
|
|
|
|
|
=cut |
1296
|
|
|
|
|
|
|
|
1297
|
|
|
|
|
|
|
sub dup { |
1298
|
50
|
|
|
50
|
1
|
138
|
my $self = shift; |
1299
|
50
|
100
|
|
|
|
187
|
return $self->{'dup'} = shift if @_; |
1300
|
46
|
|
|
|
|
169
|
return $self->{'dup'}; |
1301
|
|
|
|
|
|
|
} |
1302
|
|
|
|
|
|
|
|
1303
|
|
|
|
|
|
|
=head2 get_dup() |
1304
|
|
|
|
|
|
|
|
1305
|
|
|
|
|
|
|
Title : get_dup |
1306
|
|
|
|
|
|
|
Usage : $db->get_dup($key, $want_hash) |
1307
|
|
|
|
|
|
|
Function: retrieve all records associated with a key |
1308
|
|
|
|
|
|
|
Returns : scalar context: scalar number of records |
1309
|
|
|
|
|
|
|
array context, !$want_hash: array of values |
1310
|
|
|
|
|
|
|
array context, $want_hash: hash of value-count pairs |
1311
|
|
|
|
|
|
|
Args : as in DB_File |
1312
|
|
|
|
|
|
|
|
1313
|
|
|
|
|
|
|
=cut |
1314
|
|
|
|
|
|
|
|
1315
|
|
|
|
|
|
|
sub get_dup { |
1316
|
3
|
|
|
3
|
1
|
9
|
my $self = shift; |
1317
|
3
|
|
|
|
|
7
|
my ($key, $want_hash) = @_; |
1318
|
3
|
50
|
|
|
|
10
|
return unless $self->dbh; |
1319
|
3
|
|
|
|
|
9
|
$self->commit; |
1320
|
3
|
50
|
|
|
|
7
|
unless ($self->dup) { |
1321
|
0
|
|
|
|
|
0
|
carp("DB not created in dup context; ignoring"); |
1322
|
0
|
|
|
|
|
0
|
return; |
1323
|
|
|
|
|
|
|
} |
1324
|
3
|
|
|
|
|
19
|
$self->get_sth->execute($key); |
1325
|
3
|
|
|
|
|
21
|
my $ret = $self->get_sth->fetchall_arrayref; |
1326
|
3
|
100
|
|
|
|
23
|
return scalar @$ret unless wantarray; |
1327
|
2
|
|
|
|
|
6
|
my @ret = map {$_->[0]} @$ret; |
|
6
|
|
|
|
|
18
|
|
1328
|
2
|
100
|
|
|
|
8
|
if (!$want_hash) { |
1329
|
1
|
|
|
|
|
11
|
return @ret; |
1330
|
|
|
|
|
|
|
} |
1331
|
|
|
|
|
|
|
else { |
1332
|
1
|
|
|
|
|
3
|
my %h; |
1333
|
1
|
|
|
|
|
5
|
$h{$_}++ for @ret; |
1334
|
1
|
|
|
|
|
9
|
return %h; |
1335
|
|
|
|
|
|
|
} |
1336
|
|
|
|
|
|
|
} |
1337
|
|
|
|
|
|
|
|
1338
|
|
|
|
|
|
|
=head2 find_dup() |
1339
|
|
|
|
|
|
|
|
1340
|
|
|
|
|
|
|
Title : find_dup |
1341
|
|
|
|
|
|
|
Usage : $db->find_dup($key, $value) |
1342
|
|
|
|
|
|
|
Function: set the cursor to an instance of |
1343
|
|
|
|
|
|
|
the $key-$value pair, if one |
1344
|
|
|
|
|
|
|
exists |
1345
|
|
|
|
|
|
|
Returns : 0 on success, 1 on fail |
1346
|
|
|
|
|
|
|
Args : as in DB_File |
1347
|
|
|
|
|
|
|
|
1348
|
|
|
|
|
|
|
=cut |
1349
|
|
|
|
|
|
|
|
1350
|
|
|
|
|
|
|
sub find_dup { |
1351
|
1
|
|
|
1
|
1
|
3
|
my $self = shift; |
1352
|
1
|
|
|
|
|
3
|
my ($key, $value) = @_; |
1353
|
1
|
50
|
|
|
|
3
|
return unless $self->dbh; |
1354
|
1
|
|
|
|
|
4
|
$self->commit; |
1355
|
1
|
50
|
|
|
|
3
|
unless ($self->dup) { |
1356
|
0
|
|
|
|
|
0
|
carp("DB not created in dup context; ignoring"); |
1357
|
0
|
|
|
|
|
0
|
return; |
1358
|
|
|
|
|
|
|
} |
1359
|
1
|
|
|
|
|
19
|
$self->sel_dup_sth->bind_param(1,$key); |
1360
|
1
|
|
|
|
|
9
|
$self->sel_dup_sth->bind_param(2,$value,SQL_BLOB); |
1361
|
1
|
|
|
|
|
8
|
$self->sel_dup_sth->execute; |
1362
|
1
|
|
|
|
|
10
|
my $ret = $self->sel_dup_sth->fetch; |
1363
|
1
|
50
|
|
|
|
4
|
return 1 unless $ret; |
1364
|
1
|
|
|
|
|
4
|
${$self->CURSOR} = _find_idx($ret->[0], $self->SEQIDX); |
|
1
|
|
|
|
|
7
|
|
1365
|
1
|
|
|
|
|
6
|
return 0 |
1366
|
|
|
|
|
|
|
} |
1367
|
|
|
|
|
|
|
|
1368
|
|
|
|
|
|
|
=head2 del_dup() |
1369
|
|
|
|
|
|
|
|
1370
|
|
|
|
|
|
|
Title : del_dup |
1371
|
|
|
|
|
|
|
Usage : $db->del_dup($key, $value) |
1372
|
|
|
|
|
|
|
Function: delete all instances of the $key-$value pair |
1373
|
|
|
|
|
|
|
Returns : 0 on success, 1 on fail |
1374
|
|
|
|
|
|
|
Args : as in DB_File |
1375
|
|
|
|
|
|
|
|
1376
|
|
|
|
|
|
|
=cut |
1377
|
|
|
|
|
|
|
|
1378
|
|
|
|
|
|
|
sub del_dup { |
1379
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
1380
|
0
|
|
|
|
|
0
|
my ($key, $value) = @_; |
1381
|
0
|
|
|
|
|
0
|
my $ret; |
1382
|
0
|
0
|
|
|
|
0
|
return unless $self->dbh; |
1383
|
0
|
0
|
|
|
|
0
|
unless ($self->dup) { |
1384
|
0
|
|
|
|
|
0
|
carp("DB not created in dup context; ignoring"); |
1385
|
0
|
|
|
|
|
0
|
return; |
1386
|
|
|
|
|
|
|
} |
1387
|
0
|
|
|
|
|
0
|
$self->sel_dup_sth->bind_param(1, $key); |
1388
|
0
|
|
|
|
|
0
|
$self->sel_dup_sth->bind_param(2, $value, SQL_BLOB); |
1389
|
0
|
|
|
|
|
0
|
$self->sel_dup_sth->execute; |
1390
|
0
|
|
|
|
|
0
|
$ret = $self->sel_dup_sth->fetchall_arrayref; |
1391
|
0
|
0
|
|
|
|
0
|
unless ($ret) { |
1392
|
0
|
|
|
|
|
0
|
return 1; |
1393
|
|
|
|
|
|
|
} |
1394
|
0
|
|
|
|
|
0
|
$self->del_dup_sth->bind_param(1, $key); |
1395
|
0
|
|
|
|
|
0
|
$self->del_dup_sth->bind_param(2, $value, SQL_BLOB); |
1396
|
0
|
0
|
|
|
|
0
|
if ($self->del_dup_sth->execute) { |
1397
|
|
|
|
|
|
|
# update SEQIDX |
1398
|
0
|
|
|
|
|
0
|
foreach (map { $$_[0] } @$ret) { |
|
0
|
|
|
|
|
0
|
|
1399
|
0
|
|
|
|
|
0
|
delete ${$self->SEQIDX}[_find_idx($_,$self->SEQIDX)]; |
|
0
|
|
|
|
|
0
|
|
1400
|
|
|
|
|
|
|
} |
1401
|
0
|
|
|
|
|
0
|
$self->_wring_SEQIDX; |
1402
|
0
|
|
|
|
|
0
|
$self->{pending} = 1; |
1403
|
0
|
|
|
|
|
0
|
return 0; # success |
1404
|
|
|
|
|
|
|
} |
1405
|
|
|
|
|
|
|
else { |
1406
|
0
|
|
|
|
|
0
|
return 1; # fail |
1407
|
|
|
|
|
|
|
} |
1408
|
|
|
|
|
|
|
} |
1409
|
|
|
|
|
|
|
|
1410
|
|
|
|
|
|
|
# =head2 BDB API Emulation : internals |
1411
|
|
|
|
|
|
|
|
1412
|
|
|
|
|
|
|
# =head2 partial_match() |
1413
|
|
|
|
|
|
|
|
1414
|
|
|
|
|
|
|
# Title : partial_match |
1415
|
|
|
|
|
|
|
# Usage : |
1416
|
|
|
|
|
|
|
# Function: emulate the partial matching of DB_File::seq() with |
1417
|
|
|
|
|
|
|
# R_CURSOR flag |
1418
|
|
|
|
|
|
|
# Returns : |
1419
|
|
|
|
|
|
|
# Args : $key |
1420
|
|
|
|
|
|
|
|
1421
|
|
|
|
|
|
|
# =cut |
1422
|
|
|
|
|
|
|
|
1423
|
|
|
|
|
|
|
sub partial_match { |
1424
|
3
|
|
|
3
|
0
|
8
|
my $self = shift; |
1425
|
3
|
|
|
|
|
10
|
my ($key, $value) = @_; |
1426
|
|
|
|
|
|
|
|
1427
|
3
|
|
|
|
|
8
|
my ($status,$ret, $pk); |
1428
|
3
|
50
|
|
|
|
10
|
unless ($self->ref ne 'ARRAY') { |
1429
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": Partial matches not meaningful for arrays"); |
1430
|
|
|
|
|
|
|
} |
1431
|
3
|
|
|
|
|
14
|
my $SEQIDX = $self->SEQIDX; |
1432
|
3
|
|
|
|
|
11
|
my $CURSOR = $self->CURSOR; |
1433
|
3
|
|
|
|
|
32
|
$status = !$self->part_seq_sth->execute( $key ); |
1434
|
3
|
50
|
|
|
|
18
|
if (!$status) { # success |
1435
|
3
|
50
|
|
|
|
35
|
if ($ret = $self->{part_seq_sth}->fetch) { |
1436
|
3
|
|
|
|
|
10
|
$_[0] = $ret->[0]; $_[1] = $ret->[1]; |
|
3
|
|
|
|
|
8
|
|
1437
|
3
|
|
|
|
|
6
|
$pk = $ret->[2]; |
1438
|
3
|
50
|
|
|
|
11
|
unless (defined($$CURSOR = _find_idx($pk,$SEQIDX))) { |
1439
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": Primary key value disappeared! Please submit bug report!"); |
1440
|
|
|
|
|
|
|
} |
1441
|
3
|
|
|
|
|
11
|
return 0; |
1442
|
|
|
|
|
|
|
} |
1443
|
|
|
|
|
|
|
} |
1444
|
0
|
|
|
|
|
0
|
return 1; |
1445
|
|
|
|
|
|
|
} |
1446
|
|
|
|
|
|
|
|
1447
|
|
|
|
|
|
|
=head1 SQL Interface |
1448
|
|
|
|
|
|
|
|
1449
|
|
|
|
|
|
|
=head2 dbh() |
1450
|
|
|
|
|
|
|
|
1451
|
|
|
|
|
|
|
Title : dbh |
1452
|
|
|
|
|
|
|
Usage : $db->dbh() |
1453
|
|
|
|
|
|
|
Function: Get/set DBI database handle |
1454
|
|
|
|
|
|
|
Example : |
1455
|
|
|
|
|
|
|
Returns : DBI database handle |
1456
|
|
|
|
|
|
|
Args : |
1457
|
|
|
|
|
|
|
|
1458
|
|
|
|
|
|
|
=cut |
1459
|
|
|
|
|
|
|
|
1460
|
|
|
|
|
|
|
sub dbh { |
1461
|
721
|
|
|
721
|
1
|
1618
|
my $self = shift; |
1462
|
721
|
100
|
|
|
|
2007
|
return $self->{'dbh'} = shift if @_; |
1463
|
707
|
|
|
|
|
3389788
|
return $self->{'dbh'}; |
1464
|
|
|
|
|
|
|
} |
1465
|
|
|
|
|
|
|
|
1466
|
|
|
|
|
|
|
=head2 sth() |
1467
|
|
|
|
|
|
|
|
1468
|
|
|
|
|
|
|
Title : sth |
1469
|
|
|
|
|
|
|
Usage : $obj->sth($stmt_descriptor) |
1470
|
|
|
|
|
|
|
Function: DBI statement handle generator |
1471
|
|
|
|
|
|
|
Returns : a prepared DBI statement handle |
1472
|
|
|
|
|
|
|
Args : scalar string (statement descriptor) |
1473
|
|
|
|
|
|
|
Note : Calls such as $db->put_sth are autoloaded through |
1474
|
|
|
|
|
|
|
this method; please see source for valid descriptors |
1475
|
|
|
|
|
|
|
|
1476
|
|
|
|
|
|
|
=cut |
1477
|
|
|
|
|
|
|
|
1478
|
|
|
|
|
|
|
sub sth { |
1479
|
349
|
|
|
349
|
1
|
749
|
my $self = shift; |
1480
|
349
|
|
|
|
|
637
|
my $desc = shift; |
1481
|
349
|
50
|
|
|
|
844
|
croak(__PACKAGE__.": No active database handle") unless $self->dbh; |
1482
|
349
|
|
|
|
|
907
|
my $tbl = $STMT{$self->ref}; |
1483
|
349
|
50
|
|
|
|
1034
|
unless ($tbl) { |
1484
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": Tied type '".$self->ref."' not recognized"); |
1485
|
|
|
|
|
|
|
} |
1486
|
349
|
100
|
|
|
|
1064
|
if (!$self->{"${desc}_sth"}) { |
1487
|
40
|
50
|
|
|
|
921
|
croak(__PACKAGE__.": Statement descriptor '$desc' not recognized for type ".$self->ref) unless grep(/^$desc$/,keys %$tbl); |
1488
|
40
|
|
|
|
|
184
|
$self->{"${desc}_sth"} = $self->dbh->prepare($tbl->{$desc}); |
1489
|
|
|
|
|
|
|
} |
1490
|
349
|
|
|
|
|
10184
|
return $self->{"${desc}_sth"}; |
1491
|
|
|
|
|
|
|
} |
1492
|
|
|
|
|
|
|
|
1493
|
|
|
|
|
|
|
# autoload statement handle getters |
1494
|
|
|
|
|
|
|
# autoload filters |
1495
|
|
|
|
|
|
|
|
1496
|
|
|
|
|
|
|
sub AUTOLOAD { |
1497
|
349
|
|
|
349
|
|
841
|
my $self = shift; |
1498
|
349
|
|
|
|
|
1351
|
my @pth = split(/::/, $AUTOLOAD); |
1499
|
349
|
|
|
|
|
761
|
my $desc = $pth[-1]; |
1500
|
349
|
50
|
|
|
|
2228
|
unless ($desc =~ /^(.*?)_sth$/) { |
1501
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": Subroutine '$AUTOLOAD' is undefined in ".__PACKAGE__); |
1502
|
|
|
|
|
|
|
} |
1503
|
349
|
|
|
|
|
1229
|
$desc = $1; |
1504
|
349
|
50
|
|
|
|
859
|
if (defined $desc) { |
1505
|
349
|
50
|
|
|
|
611
|
unless (grep /^$desc$/, keys %{$STMT{$self->ref}}) { |
|
349
|
|
|
|
|
903
|
|
1506
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": Statement accessor ${desc}_sth not defined for type ".$self->ref); |
1507
|
|
|
|
|
|
|
} |
1508
|
349
|
|
|
|
|
1492
|
return $self->sth($desc); |
1509
|
|
|
|
|
|
|
} |
1510
|
|
|
|
|
|
|
else { |
1511
|
0
|
|
|
|
|
0
|
croak __PACKAGE__.": Shouldn't be here; call was to '$pth[-1]'"; |
1512
|
|
|
|
|
|
|
} |
1513
|
|
|
|
|
|
|
} |
1514
|
|
|
|
|
|
|
|
1515
|
|
|
|
|
|
|
=head2 commit() |
1516
|
|
|
|
|
|
|
|
1517
|
|
|
|
|
|
|
Title : commit |
1518
|
|
|
|
|
|
|
Usage : $db->commit() |
1519
|
|
|
|
|
|
|
Function: commit transactions |
1520
|
|
|
|
|
|
|
Returns : |
1521
|
|
|
|
|
|
|
Args : commit(1) forces, commit() commits when |
1522
|
|
|
|
|
|
|
number of pending transactions > $SQLite::MAXPEND |
1523
|
|
|
|
|
|
|
|
1524
|
|
|
|
|
|
|
=cut |
1525
|
|
|
|
|
|
|
|
1526
|
|
|
|
|
|
|
sub commit { |
1527
|
|
|
|
|
|
|
|
1528
|
149
|
|
|
149
|
1
|
275
|
my $self = shift; |
1529
|
|
|
|
|
|
|
|
1530
|
149
|
100
|
66
|
|
|
827
|
if (@_ or ($self->{pending} > $SQLite_File::MAXPEND)) { |
1531
|
14
|
50
|
|
|
|
56
|
carp(__PACKAGE__.": commit failed") unless $self->dbh->commit(); |
1532
|
14
|
|
|
|
|
157
|
$self->{pending} = 0; |
1533
|
|
|
|
|
|
|
} |
1534
|
149
|
|
|
|
|
326
|
return 1; |
1535
|
|
|
|
|
|
|
} |
1536
|
|
|
|
|
|
|
|
1537
|
|
|
|
|
|
|
=head2 pending() |
1538
|
|
|
|
|
|
|
|
1539
|
|
|
|
|
|
|
Title : pending |
1540
|
|
|
|
|
|
|
Usage : $db->pending |
1541
|
|
|
|
|
|
|
Function: Get count of pending (uncommitted) transactions |
1542
|
|
|
|
|
|
|
Returns : scalar int |
1543
|
|
|
|
|
|
|
Args : none |
1544
|
|
|
|
|
|
|
|
1545
|
|
|
|
|
|
|
=cut |
1546
|
|
|
|
|
|
|
|
1547
|
|
|
|
|
|
|
sub pending { |
1548
|
0
|
|
|
0
|
1
|
0
|
shift->{pending}; |
1549
|
|
|
|
|
|
|
} |
1550
|
|
|
|
|
|
|
|
1551
|
|
|
|
|
|
|
=head2 trace() |
1552
|
|
|
|
|
|
|
|
1553
|
|
|
|
|
|
|
Title : trace |
1554
|
|
|
|
|
|
|
Usage : $db->trace($TraceLevel) |
1555
|
|
|
|
|
|
|
Function: invoke the DBI trace logging service |
1556
|
|
|
|
|
|
|
Returns : the trace level |
1557
|
|
|
|
|
|
|
Args : scalar int trace level |
1558
|
|
|
|
|
|
|
|
1559
|
|
|
|
|
|
|
=cut |
1560
|
|
|
|
|
|
|
|
1561
|
|
|
|
|
|
|
sub trace { |
1562
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
1563
|
0
|
|
|
|
|
0
|
my $level = shift; |
1564
|
0
|
0
|
|
|
|
0
|
return unless $self->dbh; |
1565
|
0
|
|
0
|
|
|
0
|
$level ||= 3; |
1566
|
0
|
|
|
|
|
0
|
$self->dbh->{TraceLevel} = $level; |
1567
|
0
|
|
|
|
|
0
|
$self->dbh->trace; |
1568
|
0
|
|
|
|
|
0
|
return $level; |
1569
|
|
|
|
|
|
|
} |
1570
|
|
|
|
|
|
|
|
1571
|
|
|
|
|
|
|
# =head1 Private index methods : Internal |
1572
|
|
|
|
|
|
|
|
1573
|
|
|
|
|
|
|
# =head2 _index_is_stale() |
1574
|
|
|
|
|
|
|
|
1575
|
|
|
|
|
|
|
# Title : _index_is_stale |
1576
|
|
|
|
|
|
|
# Usage : |
1577
|
|
|
|
|
|
|
# Function: predicate indicating whether a _reindex has been |
1578
|
|
|
|
|
|
|
# performed since adding or updating the db |
1579
|
|
|
|
|
|
|
# Returns : |
1580
|
|
|
|
|
|
|
# Args : none |
1581
|
|
|
|
|
|
|
|
1582
|
|
|
|
|
|
|
# =cut |
1583
|
|
|
|
|
|
|
|
1584
|
|
|
|
|
|
|
sub _index_is_stale { |
1585
|
22
|
|
|
22
|
|
44
|
my $self = shift; |
1586
|
22
|
|
|
|
|
89
|
return $self->{_stale}; |
1587
|
|
|
|
|
|
|
} |
1588
|
|
|
|
|
|
|
|
1589
|
|
|
|
|
|
|
# =head2 _index() |
1590
|
|
|
|
|
|
|
|
1591
|
|
|
|
|
|
|
# Title : _index |
1592
|
|
|
|
|
|
|
# Usage : |
1593
|
|
|
|
|
|
|
# Function: initial the internal index array (maps sequential |
1594
|
|
|
|
|
|
|
# coordinates to db primary key integers) |
1595
|
|
|
|
|
|
|
# Returns : 1 on success |
1596
|
|
|
|
|
|
|
# Args : none |
1597
|
|
|
|
|
|
|
|
1598
|
|
|
|
|
|
|
# =cut |
1599
|
|
|
|
|
|
|
|
1600
|
|
|
|
|
|
|
sub _index { |
1601
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1602
|
|
|
|
|
|
|
|
1603
|
0
|
0
|
|
|
|
0
|
croak(__PACKAGE__.": _index not meaningful for index type '".$self->index->{type}."'") unless $self->index->{type} eq 'BINARY'; |
1604
|
0
|
|
|
|
|
0
|
my ($q, @order); |
1605
|
0
|
|
|
|
|
0
|
$q = $self->dbh->selectall_arrayref("SELECT pk, id FROM hash ORDER BY id"); |
1606
|
0
|
0
|
|
|
|
0
|
unless ($q) { |
1607
|
0
|
|
|
|
|
0
|
return 0; |
1608
|
|
|
|
|
|
|
} |
1609
|
0
|
|
|
|
|
0
|
@order = map { $$_[0] } @$q; |
|
0
|
|
|
|
|
0
|
|
1610
|
0
|
|
|
|
|
0
|
$self->{SEQIDX} = \@order; |
1611
|
0
|
|
|
|
|
0
|
${$self->CURSOR} = 0; |
|
0
|
|
|
|
|
0
|
|
1612
|
0
|
|
|
|
|
0
|
$self->{_stale} = 0; |
1613
|
0
|
|
|
|
|
0
|
return 1; |
1614
|
|
|
|
|
|
|
} |
1615
|
|
|
|
|
|
|
|
1616
|
|
|
|
|
|
|
# =head2 _reindex() |
1617
|
|
|
|
|
|
|
|
1618
|
|
|
|
|
|
|
# Title : _reindex |
1619
|
|
|
|
|
|
|
# Usage : |
1620
|
|
|
|
|
|
|
# Function: reorder SEQIDX to reflect BTREE ordering, |
1621
|
|
|
|
|
|
|
# preserving cursor |
1622
|
|
|
|
|
|
|
# Returns : true on success |
1623
|
|
|
|
|
|
|
# Args : none |
1624
|
|
|
|
|
|
|
|
1625
|
|
|
|
|
|
|
# =cut |
1626
|
|
|
|
|
|
|
|
1627
|
|
|
|
|
|
|
sub _reindex { |
1628
|
4
|
|
|
4
|
|
11
|
my $self = shift; |
1629
|
|
|
|
|
|
|
|
1630
|
4
|
50
|
|
|
|
17
|
croak(__PACKAGE__.": _reindex not meaningful for index type '".$self->index->{type}."'") unless $self->index->{type} eq 'BINARY'; |
1631
|
4
|
|
|
|
|
9
|
my ($q, @order); |
1632
|
4
|
|
|
|
|
10
|
my $SEQIDX = $self->SEQIDX; |
1633
|
4
|
|
|
|
|
11
|
my $CURSOR = $self->CURSOR; |
1634
|
4
|
|
|
|
|
19
|
$self->_wring_SEQIDX; |
1635
|
4
|
|
|
|
|
14
|
$q = $self->dbh->selectall_arrayref("SELECT pk, id FROM hash ORDER BY id"); |
1636
|
4
|
50
|
|
|
|
529
|
unless ($q) { |
1637
|
0
|
|
|
|
|
0
|
return 0; |
1638
|
|
|
|
|
|
|
} |
1639
|
4
|
|
|
|
|
17
|
@order = map { $$_[0] } @$q; |
|
25
|
|
|
|
|
46
|
|
1640
|
4
|
50
|
|
|
|
15
|
if (defined $$CURSOR) { |
1641
|
4
|
|
|
|
|
21
|
$$CURSOR = _find_idx($$SEQIDX[$$CURSOR],\@order); |
1642
|
|
|
|
|
|
|
} |
1643
|
|
|
|
|
|
|
else { |
1644
|
0
|
|
|
|
|
0
|
$$CURSOR = 0; |
1645
|
|
|
|
|
|
|
} |
1646
|
4
|
|
|
|
|
14
|
$self->{SEQIDX} = \@order; |
1647
|
4
|
|
|
|
|
13
|
$self->{_stale} = 0; |
1648
|
4
|
|
|
|
|
20
|
return 1; |
1649
|
|
|
|
|
|
|
} |
1650
|
|
|
|
|
|
|
|
1651
|
|
|
|
|
|
|
# =head2 _find_idx() |
1652
|
|
|
|
|
|
|
|
1653
|
|
|
|
|
|
|
# Title : _find_idx |
1654
|
|
|
|
|
|
|
# Usage : |
1655
|
|
|
|
|
|
|
# Function: search of array for index corresponding |
1656
|
|
|
|
|
|
|
# to a given value |
1657
|
|
|
|
|
|
|
# Returns : scalar int (target array index) |
1658
|
|
|
|
|
|
|
# Args : scalar int (target value), array ref (index array) |
1659
|
|
|
|
|
|
|
|
1660
|
|
|
|
|
|
|
# =cut |
1661
|
|
|
|
|
|
|
|
1662
|
|
|
|
|
|
|
sub _find_idx { |
1663
|
10
|
|
|
10
|
|
28
|
my ($pk, $seqidx) = @_; |
1664
|
10
|
|
|
|
|
25
|
my $i; |
1665
|
10
|
|
|
|
|
34
|
for (0..$#$seqidx) { |
1666
|
39
|
|
|
|
|
51
|
$i = $_; |
1667
|
39
|
50
|
|
|
|
72
|
next unless defined $$seqidx[$_]; |
1668
|
39
|
100
|
|
|
|
83
|
last if $pk == $$seqidx[$_]; |
1669
|
|
|
|
|
|
|
} |
1670
|
10
|
|
33
|
|
|
75
|
return (defined $$seqidx[$i] and $pk == $$seqidx[$i] ? $i : undef); |
1671
|
|
|
|
|
|
|
} |
1672
|
|
|
|
|
|
|
|
1673
|
|
|
|
|
|
|
# =head2 _wring_SEQIDX() |
1674
|
|
|
|
|
|
|
|
1675
|
|
|
|
|
|
|
# Title : _wring_SEQIDX |
1676
|
|
|
|
|
|
|
# Usage : |
1677
|
|
|
|
|
|
|
# Function: remove undef'ed values from SEQIDX, |
1678
|
|
|
|
|
|
|
# preserving cursor |
1679
|
|
|
|
|
|
|
# Returns : |
1680
|
|
|
|
|
|
|
# Args : none |
1681
|
|
|
|
|
|
|
|
1682
|
|
|
|
|
|
|
# =cut |
1683
|
|
|
|
|
|
|
|
1684
|
|
|
|
|
|
|
sub _wring_SEQIDX { |
1685
|
10
|
|
|
10
|
|
20
|
my $self = shift; |
1686
|
10
|
|
|
|
|
29
|
my $SEQIDX = $self->SEQIDX; |
1687
|
10
|
|
|
|
|
31
|
my $CURSOR = $self->CURSOR; |
1688
|
10
|
100
|
|
|
|
35
|
$$CURSOR = 0 unless defined $$CURSOR; |
1689
|
10
|
|
|
|
|
24
|
my ($i, $j, @a); |
1690
|
10
|
|
|
|
|
19
|
$j = 0; |
1691
|
10
|
|
|
|
|
39
|
for $i (0..$#$SEQIDX) { |
1692
|
66
|
100
|
|
|
|
127
|
if (defined $$SEQIDX[$i]) { |
1693
|
62
|
100
|
|
|
|
130
|
$$CURSOR = $j if $$CURSOR == $i; |
1694
|
62
|
|
|
|
|
182
|
$a[$j++] = $$SEQIDX[$i]; |
1695
|
|
|
|
|
|
|
} |
1696
|
|
|
|
|
|
|
else { |
1697
|
4
|
50
|
|
|
|
12
|
$$CURSOR = $i+1 if $$CURSOR == $i; |
1698
|
|
|
|
|
|
|
} |
1699
|
|
|
|
|
|
|
} |
1700
|
10
|
|
|
|
|
33
|
@$SEQIDX = @a; |
1701
|
10
|
|
|
|
|
26
|
return; |
1702
|
|
|
|
|
|
|
} |
1703
|
|
|
|
|
|
|
|
1704
|
|
|
|
|
|
|
# =head2 _get_pk() |
1705
|
|
|
|
|
|
|
|
1706
|
|
|
|
|
|
|
# Title : _get_pk |
1707
|
|
|
|
|
|
|
# Usage : |
1708
|
|
|
|
|
|
|
# Function: provide an unused primary key integer for seq access |
1709
|
|
|
|
|
|
|
# Returns : scalar int |
1710
|
|
|
|
|
|
|
# Args : none |
1711
|
|
|
|
|
|
|
|
1712
|
|
|
|
|
|
|
# =cut |
1713
|
|
|
|
|
|
|
|
1714
|
|
|
|
|
|
|
sub _get_pk { |
1715
|
40
|
|
|
40
|
|
84
|
my $self = shift; |
1716
|
|
|
|
|
|
|
# do the primary key auditing for the cursor functions... |
1717
|
40
|
|
|
|
|
109
|
return ++$AUTOPK; |
1718
|
|
|
|
|
|
|
} |
1719
|
|
|
|
|
|
|
|
1720
|
|
|
|
|
|
|
# =head2 _last_pk |
1721
|
|
|
|
|
|
|
|
1722
|
|
|
|
|
|
|
# Title : _last_pk |
1723
|
|
|
|
|
|
|
# Usage : $obj->_last_pk($newval) |
1724
|
|
|
|
|
|
|
# Function: the primary key integer returned on the last FETCH |
1725
|
|
|
|
|
|
|
# Example : |
1726
|
|
|
|
|
|
|
# Returns : value of _last_pk (a scalar) |
1727
|
|
|
|
|
|
|
# Args : on set, new value (a scalar or undef, optional) |
1728
|
|
|
|
|
|
|
|
1729
|
|
|
|
|
|
|
# =cut |
1730
|
|
|
|
|
|
|
|
1731
|
|
|
|
|
|
|
sub _last_pk { |
1732
|
101
|
|
|
101
|
|
186
|
my $self = shift; |
1733
|
|
|
|
|
|
|
|
1734
|
101
|
100
|
|
|
|
476
|
return $self->{'_last_pk'} = shift if @_; |
1735
|
16
|
|
|
|
|
87
|
return $self->{'_last_pk'}; |
1736
|
|
|
|
|
|
|
} |
1737
|
|
|
|
|
|
|
|
1738
|
|
|
|
|
|
|
# =head2 Array object helper functions : internal |
1739
|
|
|
|
|
|
|
|
1740
|
|
|
|
|
|
|
# =cut |
1741
|
|
|
|
|
|
|
|
1742
|
|
|
|
|
|
|
sub len { |
1743
|
38
|
|
|
38
|
0
|
57
|
scalar @{shift->SEQIDX}; |
|
38
|
|
|
|
|
83
|
|
1744
|
|
|
|
|
|
|
} |
1745
|
|
|
|
|
|
|
|
1746
|
|
|
|
|
|
|
sub get_idx { |
1747
|
55
|
|
|
55
|
0
|
113
|
my $self = shift; |
1748
|
55
|
|
|
|
|
90
|
my $index = shift; |
1749
|
55
|
|
|
|
|
115
|
my $SEQIDX = $self->SEQIDX; |
1750
|
55
|
100
|
|
|
|
772
|
return $$SEQIDX[$index] if defined $$SEQIDX[$index]; |
1751
|
16
|
|
|
|
|
37
|
push @$SEQIDX, $AUTOKEY; |
1752
|
16
|
|
|
|
|
803
|
$$SEQIDX[$index] = $AUTOKEY++; |
1753
|
|
|
|
|
|
|
} |
1754
|
|
|
|
|
|
|
|
1755
|
|
|
|
|
|
|
sub shift_idx { |
1756
|
3
|
|
|
3
|
0
|
6
|
my $self = shift; |
1757
|
3
|
|
|
|
|
6
|
return shift( @{$self->SEQIDX} ); |
|
3
|
|
|
|
|
7
|
|
1758
|
|
|
|
|
|
|
} |
1759
|
|
|
|
|
|
|
|
1760
|
|
|
|
|
|
|
# returns the set of new db ids to use |
1761
|
|
|
|
|
|
|
sub unshift_idx { |
1762
|
2
|
|
|
2
|
0
|
8
|
my $self = shift; |
1763
|
2
|
|
|
|
|
7
|
my $n = shift; |
1764
|
2
|
|
|
|
|
5
|
my @new; |
1765
|
2
|
|
|
|
|
15
|
push(@new, $AUTOKEY++) for (0..$n-1); |
1766
|
2
|
|
|
|
|
6
|
unshift @{$self->SEQIDX}, @new; |
|
2
|
|
|
|
|
8
|
|
1767
|
2
|
|
|
|
|
8
|
return @new; |
1768
|
|
|
|
|
|
|
} |
1769
|
|
|
|
|
|
|
|
1770
|
|
|
|
|
|
|
sub rm_idx { |
1771
|
4
|
|
|
4
|
0
|
12
|
my $self = shift; |
1772
|
4
|
|
|
|
|
8
|
my $index = shift; |
1773
|
4
|
50
|
|
|
|
8
|
unless (delete ${$self->SEQIDX}[$index]) { |
|
4
|
|
|
|
|
10
|
|
1774
|
0
|
|
|
|
|
0
|
warn("Element $index did not exist"); |
1775
|
|
|
|
|
|
|
} |
1776
|
|
|
|
|
|
|
} |
1777
|
|
|
|
|
|
|
|
1778
|
|
|
|
|
|
|
1; |
1779
|
|
|
|
|
|
|
|
1780
|
|
|
|
|
|
|
|
1781
|
|
|
|
|
|
|
package #hide from PAUSE |
1782
|
|
|
|
|
|
|
SQLite_File::HASHINFO; |
1783
|
6
|
|
|
6
|
|
178
|
use strict; |
|
6
|
|
|
|
|
22
|
|
|
6
|
|
|
|
|
225
|
|
1784
|
6
|
|
|
6
|
|
51
|
use warnings; |
|
6
|
|
|
|
|
17
|
|
|
6
|
|
|
|
|
782
|
|
1785
|
|
|
|
|
|
|
|
1786
|
|
|
|
|
|
|
# a hashinfo class stub |
1787
|
|
|
|
|
|
|
sub new { |
1788
|
6
|
|
|
6
|
|
17
|
my $class = shift; |
1789
|
6
|
|
|
|
|
18
|
my $self = bless({}, $class); |
1790
|
6
|
|
|
|
|
64
|
$self->{type} = 'HASH'; |
1791
|
6
|
|
|
|
|
24
|
return $self; |
1792
|
|
|
|
|
|
|
} |
1793
|
|
|
|
|
|
|
|
1794
|
|
|
|
|
|
|
1; |
1795
|
|
|
|
|
|
|
|
1796
|
|
|
|
|
|
|
package #hide from PAUSE |
1797
|
|
|
|
|
|
|
SQLite_File::BTREEINFO; |
1798
|
6
|
|
|
6
|
|
47
|
use strict; |
|
6
|
|
|
|
|
16
|
|
|
6
|
|
|
|
|
404
|
|
1799
|
6
|
|
|
6
|
|
39
|
use warnings; |
|
6
|
|
|
|
|
26
|
|
|
6
|
|
|
|
|
760
|
|
1800
|
|
|
|
|
|
|
|
1801
|
|
|
|
|
|
|
# a btreeinfo class stub |
1802
|
|
|
|
|
|
|
sub new { |
1803
|
6
|
|
|
6
|
|
15
|
my $class = shift; |
1804
|
6
|
|
|
|
|
23
|
my $self = bless({}, $class); |
1805
|
6
|
|
|
|
|
32
|
$self->{type} = 'BINARY'; |
1806
|
6
|
|
|
|
|
19
|
return $self; |
1807
|
|
|
|
|
|
|
} |
1808
|
|
|
|
|
|
|
|
1809
|
|
|
|
|
|
|
1; |
1810
|
|
|
|
|
|
|
|
1811
|
|
|
|
|
|
|
package #hide from PAUSE |
1812
|
|
|
|
|
|
|
SQLite_File::RECNOINFO; |
1813
|
6
|
|
|
6
|
|
54
|
use strict; |
|
6
|
|
|
|
|
17
|
|
|
6
|
|
|
|
|
161
|
|
1814
|
6
|
|
|
6
|
|
38
|
use warnings; |
|
6
|
|
|
|
|
18
|
|
|
6
|
|
|
|
|
565
|
|
1815
|
|
|
|
|
|
|
|
1816
|
|
|
|
|
|
|
# a recnoinfo class stub |
1817
|
|
|
|
|
|
|
sub new { |
1818
|
6
|
|
|
6
|
|
18
|
my $class = shift; |
1819
|
6
|
|
|
|
|
13
|
my $self = bless({}, $class); |
1820
|
6
|
|
|
|
|
30
|
$self->{type} = 'RECNO'; |
1821
|
6
|
|
|
|
|
18
|
return $self; |
1822
|
|
|
|
|
|
|
} |
1823
|
|
|
|
|
|
|
|
1824
|
|
|
|
|
|
|
1; |