line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package DBD::SQLeet; |
2
|
|
|
|
|
|
|
|
3
|
101
|
|
|
101
|
|
8141015
|
use 5.006; |
|
101
|
|
|
|
|
1217
|
|
4
|
101
|
|
|
101
|
|
534
|
use strict; |
|
101
|
|
|
|
|
179
|
|
|
101
|
|
|
|
|
1899
|
|
5
|
101
|
|
|
101
|
|
485
|
use warnings; |
|
101
|
|
|
|
|
165
|
|
|
101
|
|
|
|
|
3410
|
|
6
|
|
|
|
|
|
|
|
7
|
101
|
|
|
101
|
|
2402
|
use DBI 1.57 (); |
|
101
|
|
|
|
|
24306
|
|
|
101
|
|
|
|
|
1677
|
|
8
|
101
|
|
|
101
|
|
481
|
use DynaLoader (); |
|
101
|
|
|
|
|
175
|
|
|
101
|
|
|
|
|
9572
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
our $VERSION = '0.26.0'; |
11
|
|
|
|
|
|
|
our @ISA = 'DynaLoader'; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
# sqlite_version cache (set in the XS bootstrap) |
14
|
|
|
|
|
|
|
our ($sqlite_version, $sqlite_version_number); |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
# not sure if we still need these... |
17
|
|
|
|
|
|
|
our ($err, $errstr); |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
__PACKAGE__->bootstrap($VERSION); |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
# New or old API? |
22
|
101
|
|
|
101
|
|
634
|
use constant NEWAPI => ($DBI::VERSION >= 1.608); |
|
101
|
|
|
|
|
195
|
|
|
101
|
|
|
|
|
16317
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# global registry of collation functions, initialized with 2 builtins |
25
|
|
|
|
|
|
|
our %COLLATION; |
26
|
|
|
|
|
|
|
tie %COLLATION, 'DBD::SQLeet::_WriteOnceHash'; |
27
|
|
|
|
|
|
|
$COLLATION{perl} = sub { $_[0] cmp $_[1] }; |
28
|
101
|
|
|
101
|
|
42604
|
$COLLATION{perllocale} = sub { use locale; $_[0] cmp $_[1] }; |
|
101
|
|
|
|
|
54080
|
|
|
101
|
|
|
|
|
499
|
|
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
our $drh; |
31
|
|
|
|
|
|
|
my $methods_are_installed = 0; |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
sub driver { |
34
|
95
|
50
|
|
95
|
0
|
75104
|
return $drh if $drh; |
35
|
|
|
|
|
|
|
|
36
|
95
|
50
|
50
|
|
|
731
|
if (!$methods_are_installed && DBD::SQLeet::NEWAPI ) { |
37
|
95
|
|
|
|
|
408
|
DBI->setup_driver('DBD::SQLeet'); |
38
|
|
|
|
|
|
|
|
39
|
95
|
|
|
|
|
3346
|
DBD::SQLeet::db->install_method('sqlite_last_insert_rowid'); |
40
|
95
|
|
|
|
|
5405
|
DBD::SQLeet::db->install_method('sqlite_busy_timeout'); |
41
|
95
|
|
|
|
|
3010
|
DBD::SQLeet::db->install_method('sqlite_create_function'); |
42
|
95
|
|
|
|
|
2860
|
DBD::SQLeet::db->install_method('sqlite_create_aggregate'); |
43
|
95
|
|
|
|
|
2760
|
DBD::SQLeet::db->install_method('sqlite_create_collation'); |
44
|
95
|
|
|
|
|
3118
|
DBD::SQLeet::db->install_method('sqlite_collation_needed'); |
45
|
95
|
|
|
|
|
2698
|
DBD::SQLeet::db->install_method('sqlite_progress_handler'); |
46
|
95
|
|
|
|
|
2771
|
DBD::SQLeet::db->install_method('sqlite_commit_hook'); |
47
|
95
|
|
|
|
|
2928
|
DBD::SQLeet::db->install_method('sqlite_rollback_hook'); |
48
|
95
|
|
|
|
|
3013
|
DBD::SQLeet::db->install_method('sqlite_update_hook'); |
49
|
95
|
|
|
|
|
2845
|
DBD::SQLeet::db->install_method('sqlite_set_authorizer'); |
50
|
95
|
|
|
|
|
2790
|
DBD::SQLeet::db->install_method('sqlite_backup_from_file'); |
51
|
95
|
|
|
|
|
2912
|
DBD::SQLeet::db->install_method('sqlite_backup_to_file'); |
52
|
95
|
|
|
|
|
3257
|
DBD::SQLeet::db->install_method('sqlite_enable_load_extension'); |
53
|
95
|
|
|
|
|
2975
|
DBD::SQLeet::db->install_method('sqlite_load_extension'); |
54
|
95
|
|
|
|
|
2898
|
DBD::SQLeet::db->install_method('sqlite_register_fts3_perl_tokenizer'); |
55
|
95
|
|
|
|
|
3434
|
DBD::SQLeet::db->install_method('sqlite_trace', { O => 0x0004 }); |
56
|
95
|
|
|
|
|
3291
|
DBD::SQLeet::db->install_method('sqlite_profile', { O => 0x0004 }); |
57
|
95
|
|
|
|
|
3178
|
DBD::SQLeet::db->install_method('sqlite_table_column_metadata', { O => 0x0004 }); |
58
|
95
|
|
|
|
|
3031
|
DBD::SQLeet::db->install_method('sqlite_db_filename', { O => 0x0004 }); |
59
|
95
|
|
|
|
|
3119
|
DBD::SQLeet::db->install_method('sqlite_db_status', { O => 0x0004 }); |
60
|
95
|
|
|
|
|
3521
|
DBD::SQLeet::st->install_method('sqlite_st_status', { O => 0x0004 }); |
61
|
95
|
|
|
|
|
3179
|
DBD::SQLeet::db->install_method('sqlite_create_module'); |
62
|
|
|
|
|
|
|
|
63
|
95
|
|
|
|
|
2663
|
$methods_are_installed++; |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
95
|
|
|
|
|
922
|
$drh = DBI::_new_drh( "$_[0]::dr", { |
67
|
|
|
|
|
|
|
Name => 'SQLite', |
68
|
|
|
|
|
|
|
Version => $VERSION, |
69
|
|
|
|
|
|
|
Attribution => 'DBD::SQLeet by Dimitar D. Mitov et al', |
70
|
|
|
|
|
|
|
} ); |
71
|
|
|
|
|
|
|
|
72
|
95
|
|
|
|
|
4042
|
return $drh; |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
sub CLONE { |
76
|
0
|
|
|
0
|
|
0
|
undef $drh; |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
package # hide from PAUSE |
81
|
|
|
|
|
|
|
DBD::SQLeet::dr; |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
sub connect { |
84
|
253
|
|
|
253
|
|
4455160
|
my ($drh, $dbname, $user, $auth, $attr) = @_; |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
# Default PrintWarn to the value of $^W |
87
|
|
|
|
|
|
|
# unless ( defined $attr->{PrintWarn} ) { |
88
|
|
|
|
|
|
|
# $attr->{PrintWarn} = $^W ? 1 : 0; |
89
|
|
|
|
|
|
|
# } |
90
|
|
|
|
|
|
|
|
91
|
253
|
|
|
|
|
1658
|
my $dbh = DBI::_new_dbh( $drh, { |
92
|
|
|
|
|
|
|
Name => $dbname, |
93
|
|
|
|
|
|
|
} ); |
94
|
|
|
|
|
|
|
|
95
|
253
|
|
|
|
|
9143
|
my $real = $dbname; |
96
|
253
|
100
|
|
|
|
1170
|
if ($dbname =~ /=/) { |
97
|
238
|
|
|
|
|
978
|
foreach my $attrib (split(/;/, $dbname)) { |
98
|
240
|
|
|
|
|
864
|
my ($key, $value) = split(/=/, $attrib, 2); |
99
|
240
|
100
|
|
|
|
1559
|
if ($key =~ /^(?:db(?:name)?|database)$/) { |
|
|
100
|
|
|
|
|
|
100
|
227
|
|
|
|
|
659
|
$real = $value; |
101
|
|
|
|
|
|
|
} elsif ($key eq 'uri') { |
102
|
6
|
|
|
|
|
10
|
$real = $value; |
103
|
6
|
|
|
|
|
28
|
$attr->{sqlite_open_flags} |= DBD::SQLeet::OPEN_URI(); |
104
|
|
|
|
|
|
|
} else { |
105
|
7
|
|
|
|
|
24
|
$attr->{$key} = $value; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
253
|
100
|
|
|
|
859
|
if (my $flags = $attr->{sqlite_open_flags}) { |
111
|
18
|
100
|
|
|
|
92
|
unless ($flags & (DBD::SQLeet::OPEN_READONLY() | DBD::SQLeet::OPEN_READWRITE())) { |
112
|
12
|
|
|
|
|
32
|
$attr->{sqlite_open_flags} |= DBD::SQLeet::OPEN_READWRITE() | DBD::SQLeet::OPEN_CREATE(); |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
# To avoid unicode and long file name problems on Windows, |
117
|
|
|
|
|
|
|
# convert to the shortname if the file (or parent directory) exists. |
118
|
253
|
0
|
33
|
|
|
1310
|
if ($^O =~ /MSWin32/ and $real ne ':memory:' and $real ne '' and $real !~ /^file:/ and !-f $real) { |
|
|
|
33
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
119
|
0
|
|
|
|
|
0
|
require File::Basename; |
120
|
0
|
|
|
|
|
0
|
my ($file, $dir, $suffix) = File::Basename::fileparse($real); |
121
|
|
|
|
|
|
|
# We are creating a new file. |
122
|
|
|
|
|
|
|
# Does the directory it's in at least exist? |
123
|
0
|
0
|
|
|
|
0
|
if (-d $dir) { |
124
|
0
|
|
|
|
|
0
|
require Win32; |
125
|
0
|
|
|
|
|
0
|
$real = join '', grep { defined } Win32::GetShortPathName($dir), $file, $suffix; |
|
0
|
|
|
|
|
0
|
|
126
|
|
|
|
|
|
|
} else { |
127
|
|
|
|
|
|
|
# SQLite can't do mkpath anyway. |
128
|
|
|
|
|
|
|
# So let it go through as it and fail. |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
# Hand off to the actual login function |
133
|
253
|
100
|
|
|
|
88848
|
DBD::SQLeet::db::_login($dbh, $real, $user, $auth, $attr) or return undef; |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
# Register the on-demand collation installer, REGEXP function and |
136
|
|
|
|
|
|
|
# perl tokenizer |
137
|
247
|
|
|
|
|
800
|
if (DBD::SQLeet::NEWAPI) { |
138
|
247
|
|
|
|
|
3132
|
$dbh->sqlite_collation_needed( \&install_collation ); |
139
|
247
|
|
|
|
|
2892
|
$dbh->sqlite_create_function( "REGEXP", 2, \®exp ); |
140
|
247
|
|
|
|
|
30066
|
$dbh->sqlite_register_fts3_perl_tokenizer(); |
141
|
|
|
|
|
|
|
} else { |
142
|
|
|
|
|
|
|
$dbh->func(\&install_collation, "collation_needed"); |
143
|
|
|
|
|
|
|
$dbh->func("REGEXP", 2, \®exp, "create_function"); |
144
|
|
|
|
|
|
|
$dbh->func("register_fts3_perl_tokenizer"); |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
# HACK: Since PrintWarn = 0 doesn't seem to actually prevent warnings |
148
|
|
|
|
|
|
|
# in DBD::SQLeet we set Warn to false if PrintWarn is false. |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# NOTE: According to the explanation by timbunce, |
151
|
|
|
|
|
|
|
# "Warn is meant to report on bad practices or problems with |
152
|
|
|
|
|
|
|
# the DBI itself (hence always on by default), while PrintWarn |
153
|
|
|
|
|
|
|
# is meant to report warnings coming from the database." |
154
|
|
|
|
|
|
|
# That is, if you want to disable an ineffective rollback warning |
155
|
|
|
|
|
|
|
# etc (due to bad practices), you should turn off Warn, |
156
|
|
|
|
|
|
|
# and to silence other warnings, turn off PrintWarn. |
157
|
|
|
|
|
|
|
# Warn and PrintWarn are independent, and turning off PrintWarn |
158
|
|
|
|
|
|
|
# does not silence those warnings that should be controlled by |
159
|
|
|
|
|
|
|
# Warn. |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# unless ( $attr->{PrintWarn} ) { |
162
|
|
|
|
|
|
|
# $attr->{Warn} = 0; |
163
|
|
|
|
|
|
|
# } |
164
|
|
|
|
|
|
|
|
165
|
247
|
|
|
|
|
1622
|
return $dbh; |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
sub install_collation { |
169
|
12
|
|
|
12
|
|
27
|
my $dbh = shift; |
170
|
12
|
|
|
|
|
21
|
my $name = shift; |
171
|
12
|
|
|
|
|
54
|
my $collation = $DBD::SQLeet::COLLATION{$name}; |
172
|
12
|
50
|
|
|
|
72
|
unless ($collation) { |
173
|
0
|
0
|
|
|
|
0
|
warn "Can't install unknown collation: $name" if $dbh->{PrintWarn}; |
174
|
0
|
|
|
|
|
0
|
return; |
175
|
|
|
|
|
|
|
} |
176
|
12
|
|
|
|
|
15
|
if (DBD::SQLeet::NEWAPI) { |
177
|
12
|
|
|
|
|
62
|
$dbh->sqlite_create_collation( $name => $collation ); |
178
|
|
|
|
|
|
|
} else { |
179
|
|
|
|
|
|
|
$dbh->func($name => $collation, "create_collation"); |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# default implementation for sqlite 'REGEXP' infix operator. |
184
|
|
|
|
|
|
|
# Note : args are reversed, i.e. "a REGEXP b" calls REGEXP(b, a) |
185
|
|
|
|
|
|
|
# (see http://www.sqlite.org/vtab.html#xfindfunction) |
186
|
|
|
|
|
|
|
sub regexp { |
187
|
101
|
|
|
101
|
|
89394
|
use locale; |
|
101
|
|
|
|
|
211
|
|
|
101
|
|
|
|
|
432
|
|
188
|
392
|
100
|
66
|
392
|
|
2536
|
return if !defined $_[0] || !defined $_[1]; |
189
|
264
|
|
|
|
|
2170
|
return scalar($_[1] =~ $_[0]); |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
package # hide from PAUSE |
193
|
|
|
|
|
|
|
DBD::SQLeet::db; |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
sub prepare { |
196
|
1117
|
|
|
1117
|
|
952703
|
my $dbh = shift; |
197
|
1117
|
|
|
|
|
1721
|
my $sql = shift; |
198
|
1117
|
50
|
|
|
|
2559
|
$sql = '' unless defined $sql; |
199
|
|
|
|
|
|
|
|
200
|
1117
|
|
|
|
|
4050
|
my $sth = DBI::_new_sth( $dbh, { |
201
|
|
|
|
|
|
|
Statement => $sql, |
202
|
|
|
|
|
|
|
} ); |
203
|
|
|
|
|
|
|
|
204
|
1117
|
100
|
|
|
|
80051
|
DBD::SQLeet::st::_prepare($sth, $sql, @_) or return undef; |
205
|
|
|
|
|
|
|
|
206
|
1107
|
|
|
|
|
15448
|
return $sth; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
sub do { |
210
|
2877
|
|
|
2877
|
|
2795513
|
my ($dbh, $statement, $attr, @bind_values) = @_; |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
# shortcut |
213
|
2877
|
|
|
|
|
9477
|
my $allow_multiple_statements = $dbh->FETCH('sqlite_allow_multiple_statements'); |
214
|
2877
|
100
|
100
|
|
|
13266
|
if (defined $statement && !defined $attr && !@bind_values) { |
|
|
|
100
|
|
|
|
|
215
|
|
|
|
|
|
|
# _do() (i.e. sqlite3_exec()) runs semicolon-separate SQL |
216
|
|
|
|
|
|
|
# statements, which is handy but insecure sometimes. |
217
|
|
|
|
|
|
|
# Use this only when it's safe or explicitly allowed. |
218
|
2778
|
100
|
66
|
|
|
6752
|
if (index($statement, ';') == -1 or $allow_multiple_statements) { |
219
|
2755
|
|
|
|
|
11024717
|
return DBD::SQLeet::db::_do($dbh, $statement); |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
122
|
|
|
|
|
196
|
my @copy = @{[@bind_values]}; |
|
122
|
|
|
|
|
343
|
|
224
|
122
|
|
|
|
|
234
|
my $rows = 0; |
225
|
|
|
|
|
|
|
|
226
|
122
|
|
|
|
|
295
|
while ($statement) { |
227
|
127
|
100
|
|
|
|
447
|
my $sth = $dbh->prepare($statement, $attr) or return undef; |
228
|
119
|
100
|
|
|
|
8978
|
$sth->execute(splice @copy, 0, $sth->{NUM_OF_PARAMS}) or return undef; |
229
|
115
|
|
|
|
|
1052
|
$rows += $sth->rows; |
230
|
|
|
|
|
|
|
# XXX: not sure why but $dbh->{sqlite...} wouldn't work here |
231
|
115
|
100
|
|
|
|
1557
|
last unless $allow_multiple_statements; |
232
|
8
|
|
|
|
|
103
|
$statement = $sth->{sqlite_unprepared_statements}; |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
# always return true if no error |
236
|
110
|
100
|
|
|
|
848
|
return ($rows == 0) ? "0E0" : $rows; |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
sub ping { |
240
|
1
|
|
|
1
|
|
1252
|
my $dbh = shift; |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
# $file may be undef (ie. in-memory/temporary database) |
243
|
1
|
|
|
|
|
21
|
my $file = DBD::SQLeet::NEWAPI ? $dbh->sqlite_db_filename |
244
|
|
|
|
|
|
|
: $dbh->func("db_filename"); |
245
|
|
|
|
|
|
|
|
246
|
1
|
50
|
33
|
|
|
7
|
return 0 if $file && !-f $file; |
247
|
1
|
50
|
|
|
|
11
|
return $dbh->FETCH('Active') ? 1 : 0; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
sub _get_version { |
251
|
0
|
|
|
0
|
|
0
|
return (DBD::SQLeet::db::FETCH($_[0], 'sqlite_version')); |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
my %info = ( |
255
|
|
|
|
|
|
|
17 => 'SQLite', # SQL_DBMS_NAME |
256
|
|
|
|
|
|
|
18 => \&_get_version, # SQL_DBMS_VER |
257
|
|
|
|
|
|
|
29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR |
258
|
|
|
|
|
|
|
); |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
sub get_info { |
261
|
63
|
|
|
63
|
|
393
|
my($dbh, $info_type) = @_; |
262
|
63
|
|
|
|
|
162
|
my $v = $info{int($info_type)}; |
263
|
63
|
50
|
|
|
|
234
|
$v = $v->($dbh) if ref $v eq 'CODE'; |
264
|
63
|
|
|
|
|
143
|
return $v; |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
sub _attached_database_list { |
268
|
21
|
|
|
21
|
|
32
|
my $dbh = shift; |
269
|
21
|
|
|
|
|
33
|
my @attached; |
270
|
|
|
|
|
|
|
|
271
|
21
|
50
|
|
|
|
70
|
my $sth_databases = $dbh->prepare('PRAGMA database_list') or return; |
272
|
21
|
50
|
|
|
|
198
|
$sth_databases->execute or return; |
273
|
21
|
|
|
|
|
519
|
while (my $db_info = $sth_databases->fetchrow_hashref) { |
274
|
47
|
100
|
|
|
|
533
|
push @attached, $db_info->{name} if $db_info->{seq} >= 2; |
275
|
|
|
|
|
|
|
} |
276
|
21
|
|
|
|
|
263
|
return @attached; |
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
# SQL/CLI (ISO/IEC JTC 1/SC 32 N 0595), 6.63 Tables |
280
|
|
|
|
|
|
|
# Based on DBD::Oracle's |
281
|
|
|
|
|
|
|
# See also http://www.ch-werner.de/sqliteodbc/html/sqlite3odbc_8c.html#a213 |
282
|
|
|
|
|
|
|
sub table_info { |
283
|
16
|
|
|
16
|
|
9830
|
my ($dbh, $cat_val, $sch_val, $tbl_val, $typ_val, $attr) = @_; |
284
|
|
|
|
|
|
|
|
285
|
16
|
|
|
|
|
29
|
my @where = (); |
286
|
16
|
|
|
|
|
20
|
my $sql; |
287
|
16
|
100
|
100
|
|
|
151
|
if (defined($cat_val) && $cat_val eq '%' |
|
|
100
|
66
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
288
|
|
|
|
|
|
|
&& defined($sch_val) && $sch_val eq '' |
289
|
|
|
|
|
|
|
&& defined($tbl_val) && $tbl_val eq '') { # Rule 19a |
290
|
1
|
|
|
|
|
2
|
$sql = <<'END_SQL'; |
291
|
|
|
|
|
|
|
SELECT NULL TABLE_CAT |
292
|
|
|
|
|
|
|
, NULL TABLE_SCHEM |
293
|
|
|
|
|
|
|
, NULL TABLE_NAME |
294
|
|
|
|
|
|
|
, NULL TABLE_TYPE |
295
|
|
|
|
|
|
|
, NULL REMARKS |
296
|
|
|
|
|
|
|
END_SQL |
297
|
|
|
|
|
|
|
} elsif ( defined($cat_val) && $cat_val eq '' |
298
|
|
|
|
|
|
|
&& defined($sch_val) && $sch_val eq '%' |
299
|
|
|
|
|
|
|
&& defined($tbl_val) && $tbl_val eq '') { # Rule 19b |
300
|
1
|
|
|
|
|
4
|
$sql = <<'END_SQL'; |
301
|
|
|
|
|
|
|
SELECT NULL TABLE_CAT |
302
|
|
|
|
|
|
|
, t.tn TABLE_SCHEM |
303
|
|
|
|
|
|
|
, NULL TABLE_NAME |
304
|
|
|
|
|
|
|
, NULL TABLE_TYPE |
305
|
|
|
|
|
|
|
, NULL REMARKS |
306
|
|
|
|
|
|
|
FROM ( |
307
|
|
|
|
|
|
|
SELECT 'main' tn |
308
|
|
|
|
|
|
|
UNION SELECT 'temp' tn |
309
|
|
|
|
|
|
|
END_SQL |
310
|
1
|
|
|
|
|
5
|
for my $db_name (_attached_database_list($dbh)) { |
311
|
0
|
|
|
|
|
0
|
$sql .= " UNION SELECT '$db_name' tn\n"; |
312
|
|
|
|
|
|
|
} |
313
|
1
|
|
|
|
|
5
|
$sql .= ") t\n"; |
314
|
|
|
|
|
|
|
} elsif (defined($cat_val) && $cat_val eq '' |
315
|
|
|
|
|
|
|
&& defined($sch_val) && $sch_val eq '' |
316
|
|
|
|
|
|
|
&& defined($tbl_val) && $tbl_val eq '' |
317
|
|
|
|
|
|
|
&& defined($typ_val) && $typ_val eq '%') { # Rule 19c |
318
|
1
|
|
|
|
|
2
|
$sql = <<'END_SQL'; |
319
|
|
|
|
|
|
|
SELECT NULL TABLE_CAT |
320
|
|
|
|
|
|
|
, NULL TABLE_SCHEM |
321
|
|
|
|
|
|
|
, NULL TABLE_NAME |
322
|
|
|
|
|
|
|
, t.tt TABLE_TYPE |
323
|
|
|
|
|
|
|
, NULL REMARKS |
324
|
|
|
|
|
|
|
FROM ( |
325
|
|
|
|
|
|
|
SELECT 'TABLE' tt UNION |
326
|
|
|
|
|
|
|
SELECT 'VIEW' tt UNION |
327
|
|
|
|
|
|
|
SELECT 'LOCAL TEMPORARY' tt UNION |
328
|
|
|
|
|
|
|
SELECT 'SYSTEM TABLE' tt |
329
|
|
|
|
|
|
|
) t |
330
|
|
|
|
|
|
|
ORDER BY TABLE_TYPE |
331
|
|
|
|
|
|
|
END_SQL |
332
|
|
|
|
|
|
|
} else { |
333
|
13
|
|
|
|
|
20
|
$sql = <<'END_SQL'; |
334
|
|
|
|
|
|
|
SELECT * |
335
|
|
|
|
|
|
|
FROM |
336
|
|
|
|
|
|
|
( |
337
|
|
|
|
|
|
|
SELECT NULL TABLE_CAT |
338
|
|
|
|
|
|
|
, TABLE_SCHEM |
339
|
|
|
|
|
|
|
, tbl_name TABLE_NAME |
340
|
|
|
|
|
|
|
, TABLE_TYPE |
341
|
|
|
|
|
|
|
, NULL REMARKS |
342
|
|
|
|
|
|
|
, sql sqlite_sql |
343
|
|
|
|
|
|
|
FROM ( |
344
|
|
|
|
|
|
|
SELECT 'main' TABLE_SCHEM, tbl_name, upper(type) TABLE_TYPE, sql |
345
|
|
|
|
|
|
|
FROM sqlite_master |
346
|
|
|
|
|
|
|
UNION ALL |
347
|
|
|
|
|
|
|
SELECT 'temp' TABLE_SCHEM, tbl_name, 'LOCAL TEMPORARY' TABLE_TYPE, sql |
348
|
|
|
|
|
|
|
FROM sqlite_temp_master |
349
|
|
|
|
|
|
|
END_SQL |
350
|
|
|
|
|
|
|
|
351
|
13
|
|
|
|
|
27
|
for my $db_name (_attached_database_list($dbh)) { |
352
|
9
|
|
|
|
|
34
|
$sql .= <<"END_SQL"; |
353
|
|
|
|
|
|
|
UNION ALL |
354
|
|
|
|
|
|
|
SELECT '$db_name' TABLE_SCHEM, tbl_name, upper(type) TABLE_TYPE, sql |
355
|
|
|
|
|
|
|
FROM "$db_name".sqlite_master |
356
|
|
|
|
|
|
|
END_SQL |
357
|
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
|
359
|
13
|
|
|
|
|
31
|
$sql .= <<'END_SQL'; |
360
|
|
|
|
|
|
|
UNION ALL |
361
|
|
|
|
|
|
|
SELECT 'main' TABLE_SCHEM, 'sqlite_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql |
362
|
|
|
|
|
|
|
UNION ALL |
363
|
|
|
|
|
|
|
SELECT 'temp' TABLE_SCHEM, 'sqlite_temp_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql |
364
|
|
|
|
|
|
|
) |
365
|
|
|
|
|
|
|
) |
366
|
|
|
|
|
|
|
END_SQL |
367
|
13
|
50
|
|
|
|
36
|
$attr = {} unless ref $attr eq 'HASH'; |
368
|
13
|
50
|
|
|
|
34
|
my $escape = defined $attr->{Escape} ? " ESCAPE '$attr->{Escape}'" : ''; |
369
|
13
|
100
|
|
|
|
28
|
if (defined $sch_val) { |
370
|
3
|
|
|
|
|
8
|
push @where, "TABLE_SCHEM LIKE '$sch_val'$escape"; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
13
|
100
|
|
|
|
22
|
if (defined $tbl_val) { |
374
|
11
|
|
|
|
|
28
|
push @where, "TABLE_NAME LIKE '$tbl_val'$escape"; |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
13
|
100
|
|
|
|
25
|
if (defined $typ_val) { |
378
|
1
|
|
|
|
|
3
|
my $table_type_list; |
379
|
1
|
|
|
|
|
8
|
$typ_val =~ s/^\s+//; |
380
|
1
|
|
|
|
|
8
|
$typ_val =~ s/\s+$//; |
381
|
1
|
|
|
|
|
6
|
my @ttype_list = split (/\s*,\s*/, $typ_val); |
382
|
1
|
|
|
|
|
3
|
foreach my $table_type (@ttype_list) { |
383
|
1
|
50
|
|
|
|
6
|
if ($table_type !~ /^'.*'$/) { |
384
|
1
|
|
|
|
|
4
|
$table_type = "'" . $table_type . "'"; |
385
|
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
} |
387
|
1
|
|
|
|
|
3
|
$table_type_list = join(', ', @ttype_list); |
388
|
1
|
50
|
|
|
|
7
|
push @where, "TABLE_TYPE IN (\U$table_type_list)" if $table_type_list; |
389
|
|
|
|
|
|
|
} |
390
|
13
|
100
|
|
|
|
48
|
$sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where; |
391
|
13
|
|
|
|
|
24
|
$sql .= " ORDER BY TABLE_TYPE, TABLE_SCHEM, TABLE_NAME\n"; |
392
|
|
|
|
|
|
|
} |
393
|
16
|
50
|
|
|
|
51
|
my $sth = $dbh->prepare($sql) or return undef; |
394
|
16
|
50
|
|
|
|
723
|
$sth->execute or return undef; |
395
|
16
|
|
|
|
|
287
|
$sth; |
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
sub primary_key_info { |
399
|
33
|
|
|
33
|
|
17906
|
my ($dbh, $catalog, $schema, $table, $attr) = @_; |
400
|
|
|
|
|
|
|
|
401
|
33
|
|
|
|
|
279
|
my $databases = $dbh->selectall_arrayref("PRAGMA database_list", {Slice => {}}); |
402
|
|
|
|
|
|
|
|
403
|
33
|
|
|
|
|
3420
|
my @pk_info; |
404
|
33
|
|
|
|
|
76
|
for my $database (@$databases) { |
405
|
49
|
|
|
|
|
96
|
my $dbname = $database->{name}; |
406
|
49
|
100
|
66
|
|
|
138
|
next if defined $schema && $schema ne '%' && $schema ne $dbname; |
|
|
|
100
|
|
|
|
|
407
|
|
|
|
|
|
|
|
408
|
43
|
|
|
|
|
174
|
my $quoted_dbname = $dbh->quote_identifier($dbname); |
409
|
|
|
|
|
|
|
|
410
|
43
|
100
|
|
|
|
1094
|
my $master_table = |
|
|
100
|
|
|
|
|
|
411
|
|
|
|
|
|
|
($dbname eq 'main') ? 'sqlite_master' : |
412
|
|
|
|
|
|
|
($dbname eq 'temp') ? 'sqlite_temp_master' : |
413
|
|
|
|
|
|
|
$quoted_dbname.'.sqlite_master'; |
414
|
|
|
|
|
|
|
|
415
|
43
|
50
|
|
|
|
159
|
my $sth = $dbh->prepare("SELECT name, sql FROM $master_table WHERE type = ?") or return; |
416
|
43
|
50
|
|
|
|
1041
|
$sth->execute("table") or return; |
417
|
43
|
|
|
|
|
928
|
while(my $row = $sth->fetchrow_hashref) { |
418
|
55
|
|
|
|
|
125
|
my $tbname = $row->{name}; |
419
|
55
|
100
|
66
|
|
|
657
|
next if defined $table && $table ne '%' && $table ne $tbname; |
|
|
|
100
|
|
|
|
|
420
|
|
|
|
|
|
|
|
421
|
33
|
|
|
|
|
121
|
my $quoted_tbname = $dbh->quote_identifier($tbname); |
422
|
33
|
50
|
|
|
|
1018
|
my $t_sth = $dbh->prepare("PRAGMA $quoted_dbname.table_info($quoted_tbname)") or return; |
423
|
33
|
50
|
|
|
|
450
|
$t_sth->execute or return; |
424
|
33
|
|
|
|
|
68
|
my @pk; |
425
|
33
|
|
|
|
|
647
|
while(my $col = $t_sth->fetchrow_hashref) { |
426
|
52
|
100
|
|
|
|
909
|
push @pk, $col->{name} if $col->{pk}; |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
# If there're multiple primary key columns, we need to |
430
|
|
|
|
|
|
|
# find their order from one of the auto-generated unique |
431
|
|
|
|
|
|
|
# indices (note that single column integer primary key |
432
|
|
|
|
|
|
|
# doesn't create an index). |
433
|
33
|
100
|
66
|
|
|
188
|
if (@pk > 1 and $row->{sql} =~ /\bPRIMARY\s+KEY\s*\(\s* |
434
|
|
|
|
|
|
|
( |
435
|
|
|
|
|
|
|
(?: |
436
|
|
|
|
|
|
|
( |
437
|
|
|
|
|
|
|
[a-z_][a-z0-9_]* |
438
|
|
|
|
|
|
|
| (["'`])(?:\3\3|(?!\3).)+?\3(?!\3) |
439
|
|
|
|
|
|
|
| \[[^\]]+\] |
440
|
|
|
|
|
|
|
) |
441
|
|
|
|
|
|
|
\s*,\s* |
442
|
|
|
|
|
|
|
)+ |
443
|
|
|
|
|
|
|
( |
444
|
|
|
|
|
|
|
[a-z_][a-z0-9_]* |
445
|
|
|
|
|
|
|
| (["'`])(?:\5\5|(?!\5).)+?\5(?!\5) |
446
|
|
|
|
|
|
|
| \[[^\]]+\] |
447
|
|
|
|
|
|
|
) |
448
|
|
|
|
|
|
|
) |
449
|
|
|
|
|
|
|
\s*\)/six) { |
450
|
4
|
|
|
|
|
14
|
my $pk_sql = $1; |
451
|
4
|
|
|
|
|
10
|
@pk = (); |
452
|
4
|
|
|
|
|
20
|
while($pk_sql =~ / |
453
|
|
|
|
|
|
|
( |
454
|
|
|
|
|
|
|
[a-z_][a-z0-9_]* |
455
|
|
|
|
|
|
|
| (["'`])(?:\2\2|(?!\2).)+?\2(?!\2) |
456
|
|
|
|
|
|
|
| \[([^\]]+)\] |
457
|
|
|
|
|
|
|
) |
458
|
|
|
|
|
|
|
(?:\s*,\s*|$) |
459
|
|
|
|
|
|
|
/sixg) { |
460
|
9
|
|
|
|
|
27
|
my($col, $quote, $brack) = ($1, $2, $3); |
461
|
9
|
100
|
|
|
|
29
|
if (defined $quote) { |
|
|
100
|
|
|
|
|
|
462
|
|
|
|
|
|
|
# Dequote "'` |
463
|
2
|
|
|
|
|
5
|
$col = substr $col, 1, -1; |
464
|
2
|
|
|
|
|
24
|
$col =~ s/$quote$quote/$quote/g; |
465
|
|
|
|
|
|
|
} elsif (defined $brack) { |
466
|
|
|
|
|
|
|
# Dequote [] |
467
|
1
|
|
|
|
|
3
|
$col = $brack; |
468
|
|
|
|
|
|
|
} |
469
|
9
|
|
|
|
|
34
|
push @pk, $col; |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
|
473
|
33
|
100
|
|
|
|
159
|
my $key_name = $row->{sql} =~ /\bCONSTRAINT\s+(\S+|"[^"]+")\s+PRIMARY\s+KEY\s*\(/i ? $1 : 'PRIMARY KEY'; |
474
|
33
|
|
|
|
|
46
|
my $key_seq = 0; |
475
|
33
|
|
|
|
|
60
|
foreach my $pk_field (@pk) { |
476
|
38
|
|
|
|
|
925
|
push @pk_info, { |
477
|
|
|
|
|
|
|
TABLE_SCHEM => $dbname, |
478
|
|
|
|
|
|
|
TABLE_NAME => $tbname, |
479
|
|
|
|
|
|
|
COLUMN_NAME => $pk_field, |
480
|
|
|
|
|
|
|
KEY_SEQ => ++$key_seq, |
481
|
|
|
|
|
|
|
PK_NAME => $key_name, |
482
|
|
|
|
|
|
|
}; |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
} |
485
|
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
|
487
|
33
|
50
|
|
|
|
142
|
my $sponge = DBI->connect("DBI:Sponge:", '','') |
488
|
|
|
|
|
|
|
or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); |
489
|
33
|
|
|
|
|
16061
|
my @names = qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME); |
490
|
|
|
|
|
|
|
my $sth = $sponge->prepare( "primary_key_info", { |
491
|
33
|
50
|
|
|
|
69
|
rows => [ map { [ @{$_}{@names} ] } @pk_info ], |
|
38
|
|
|
|
|
45
|
|
|
38
|
|
|
|
|
321
|
|
492
|
|
|
|
|
|
|
NUM_OF_FIELDS => scalar @names, |
493
|
|
|
|
|
|
|
NAME => \@names, |
494
|
|
|
|
|
|
|
}) or return $dbh->DBI::set_err( |
495
|
|
|
|
|
|
|
$sponge->err, |
496
|
|
|
|
|
|
|
$sponge->errstr, |
497
|
|
|
|
|
|
|
); |
498
|
33
|
|
|
|
|
2576
|
return $sth; |
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
our %DBI_code_for_rule = ( |
502
|
|
|
|
|
|
|
# from DBI doc; curiously, they are not exported |
503
|
|
|
|
|
|
|
# by the DBI module. |
504
|
|
|
|
|
|
|
# codes for update/delete constraints |
505
|
|
|
|
|
|
|
'CASCADE' => 0, |
506
|
|
|
|
|
|
|
'RESTRICT' => 1, |
507
|
|
|
|
|
|
|
'SET NULL' => 2, |
508
|
|
|
|
|
|
|
'NO ACTION' => 3, |
509
|
|
|
|
|
|
|
'SET DEFAULT' => 4, |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
# codes for deferrability |
512
|
|
|
|
|
|
|
'INITIALLY DEFERRED' => 5, |
513
|
|
|
|
|
|
|
'INITIALLY IMMEDIATE' => 6, |
514
|
|
|
|
|
|
|
'NOT DEFERRABLE' => 7, |
515
|
|
|
|
|
|
|
); |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
my @FOREIGN_KEY_INFO_ODBC = ( |
518
|
|
|
|
|
|
|
'PKTABLE_CAT', # The primary (unique) key table catalog identifier. |
519
|
|
|
|
|
|
|
'PKTABLE_SCHEM', # The primary (unique) key table schema identifier. |
520
|
|
|
|
|
|
|
'PKTABLE_NAME', # The primary (unique) key table identifier. |
521
|
|
|
|
|
|
|
'PKCOLUMN_NAME', # The primary (unique) key column identifier. |
522
|
|
|
|
|
|
|
'FKTABLE_CAT', # The foreign key table catalog identifier. |
523
|
|
|
|
|
|
|
'FKTABLE_SCHEM', # The foreign key table schema identifier. |
524
|
|
|
|
|
|
|
'FKTABLE_NAME', # The foreign key table identifier. |
525
|
|
|
|
|
|
|
'FKCOLUMN_NAME', # The foreign key column identifier. |
526
|
|
|
|
|
|
|
'KEY_SEQ', # The column sequence number (starting with 1). |
527
|
|
|
|
|
|
|
'UPDATE_RULE', # The referential action for the UPDATE rule. |
528
|
|
|
|
|
|
|
'DELETE_RULE', # The referential action for the DELETE rule. |
529
|
|
|
|
|
|
|
'FK_NAME', # The foreign key name. |
530
|
|
|
|
|
|
|
'PK_NAME', # The primary (unique) key name. |
531
|
|
|
|
|
|
|
'DEFERRABILITY', # The deferrability of the foreign key constraint. |
532
|
|
|
|
|
|
|
'UNIQUE_OR_PRIMARY', # qualifies the key referenced by the foreign key |
533
|
|
|
|
|
|
|
); |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
# Column names below are not used, but listed just for completeness's sake. |
536
|
|
|
|
|
|
|
# Maybe we could add an option so that the user can choose which field |
537
|
|
|
|
|
|
|
# names will be returned; the DBI spec is not very clear about ODBC vs. CLI. |
538
|
|
|
|
|
|
|
my @FOREIGN_KEY_INFO_SQL_CLI = qw( |
539
|
|
|
|
|
|
|
UK_TABLE_CAT |
540
|
|
|
|
|
|
|
UK_TABLE_SCHEM |
541
|
|
|
|
|
|
|
UK_TABLE_NAME |
542
|
|
|
|
|
|
|
UK_COLUMN_NAME |
543
|
|
|
|
|
|
|
FK_TABLE_CAT |
544
|
|
|
|
|
|
|
FK_TABLE_SCHEM |
545
|
|
|
|
|
|
|
FK_TABLE_NAME |
546
|
|
|
|
|
|
|
FK_COLUMN_NAME |
547
|
|
|
|
|
|
|
ORDINAL_POSITION |
548
|
|
|
|
|
|
|
UPDATE_RULE |
549
|
|
|
|
|
|
|
DELETE_RULE |
550
|
|
|
|
|
|
|
FK_NAME |
551
|
|
|
|
|
|
|
UK_NAME |
552
|
|
|
|
|
|
|
DEFERABILITY |
553
|
|
|
|
|
|
|
UNIQUE_OR_PRIMARY |
554
|
|
|
|
|
|
|
); |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
sub foreign_key_info { |
557
|
6
|
|
|
6
|
|
8132
|
my ($dbh, $pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table) = @_; |
558
|
|
|
|
|
|
|
|
559
|
6
|
50
|
|
|
|
92
|
my $databases = $dbh->selectall_arrayref("PRAGMA database_list", {Slice => {}}) or return; |
560
|
|
|
|
|
|
|
|
561
|
6
|
|
|
|
|
592
|
my @fk_info; |
562
|
|
|
|
|
|
|
my %table_info; |
563
|
6
|
|
|
|
|
14
|
for my $database (@$databases) { |
564
|
12
|
|
|
|
|
22
|
my $dbname = $database->{name}; |
565
|
12
|
100
|
66
|
|
|
38
|
next if defined $fk_schema && $fk_schema ne '%' && $fk_schema ne $dbname; |
|
|
|
100
|
|
|
|
|
566
|
|
|
|
|
|
|
|
567
|
11
|
|
|
|
|
38
|
my $quoted_dbname = $dbh->quote_identifier($dbname); |
568
|
11
|
50
|
|
|
|
319
|
my $master_table = |
|
|
100
|
|
|
|
|
|
569
|
|
|
|
|
|
|
($dbname eq 'main') ? 'sqlite_master' : |
570
|
|
|
|
|
|
|
($dbname eq 'temp') ? 'sqlite_temp_master' : |
571
|
|
|
|
|
|
|
$quoted_dbname.'.sqlite_master'; |
572
|
|
|
|
|
|
|
|
573
|
11
|
50
|
|
|
|
60
|
my $tables = $dbh->selectall_arrayref("SELECT name FROM $master_table WHERE type = ?", undef, "table") or return; |
574
|
11
|
|
|
|
|
121
|
for my $table (@$tables) { |
575
|
26
|
|
|
|
|
45
|
my $tbname = $table->[0]; |
576
|
26
|
100
|
66
|
|
|
103
|
next if defined $fk_table && $fk_table ne '%' && $fk_table ne $tbname; |
|
|
|
100
|
|
|
|
|
577
|
|
|
|
|
|
|
|
578
|
10
|
|
|
|
|
31
|
my $quoted_tbname = $dbh->quote_identifier($tbname); |
579
|
10
|
50
|
|
|
|
242
|
my $sth = $dbh->prepare("PRAGMA $quoted_dbname.foreign_key_list($quoted_tbname)") or return; |
580
|
10
|
50
|
|
|
|
78
|
$sth->execute or return; |
581
|
10
|
|
|
|
|
189
|
while(my $row = $sth->fetchrow_hashref) { |
582
|
14
|
100
|
66
|
|
|
99
|
next if defined $pk_table && $pk_table ne '%' && $pk_table ne $row->{table}; |
|
|
|
100
|
|
|
|
|
583
|
|
|
|
|
|
|
|
584
|
11
|
100
|
|
|
|
26
|
unless ($table_info{$row->{table}}) { |
585
|
9
|
|
|
|
|
29
|
my $quoted_tb = $dbh->quote_identifier($row->{table}); |
586
|
9
|
|
|
|
|
197
|
for my $db (@$databases) { |
587
|
11
|
|
|
|
|
37
|
my $quoted_db = $dbh->quote_identifier($db->{name}); |
588
|
11
|
50
|
|
|
|
219
|
my $t_sth = $dbh->prepare("PRAGMA $quoted_db.table_info($quoted_tb)") or return; |
589
|
11
|
50
|
|
|
|
89
|
$t_sth->execute or return; |
590
|
11
|
|
|
|
|
23
|
my $cols = {}; |
591
|
11
|
|
|
|
|
181
|
while(my $r = $t_sth->fetchrow_hashref) { |
592
|
22
|
|
|
|
|
274
|
$cols->{$r->{name}} = $r->{pk}; |
593
|
|
|
|
|
|
|
} |
594
|
11
|
100
|
|
|
|
50
|
if (keys %$cols) { |
595
|
|
|
|
|
|
|
$table_info{$row->{table}} = { |
596
|
|
|
|
|
|
|
schema => $db->{name}, |
597
|
9
|
|
|
|
|
27
|
columns => $cols, |
598
|
|
|
|
|
|
|
}; |
599
|
9
|
|
|
|
|
82
|
last; |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
} |
602
|
|
|
|
|
|
|
} |
603
|
|
|
|
|
|
|
|
604
|
11
|
100
|
66
|
|
|
72
|
next if defined $pk_schema && $pk_schema ne '%' && $pk_schema ne $table_info{$row->{table}}{schema}; |
|
|
|
100
|
|
|
|
|
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
push @fk_info, { |
607
|
|
|
|
|
|
|
PKTABLE_CAT => undef, |
608
|
|
|
|
|
|
|
PKTABLE_SCHEM => $table_info{$row->{table}}{schema}, |
609
|
|
|
|
|
|
|
PKTABLE_NAME => $row->{table}, |
610
|
|
|
|
|
|
|
PKCOLUMN_NAME => $row->{to}, |
611
|
|
|
|
|
|
|
FKTABLE_CAT => undef, |
612
|
|
|
|
|
|
|
FKTABLE_SCHEM => $dbname, |
613
|
|
|
|
|
|
|
FKTABLE_NAME => $tbname, |
614
|
|
|
|
|
|
|
FKCOLUMN_NAME => $row->{from}, |
615
|
|
|
|
|
|
|
KEY_SEQ => $row->{seq} + 1, |
616
|
|
|
|
|
|
|
UPDATE_RULE => $DBI_code_for_rule{$row->{on_update}}, |
617
|
|
|
|
|
|
|
DELETE_RULE => $DBI_code_for_rule{$row->{on_delete}}, |
618
|
|
|
|
|
|
|
FK_NAME => undef, |
619
|
|
|
|
|
|
|
PK_NAME => undef, |
620
|
|
|
|
|
|
|
DEFERRABILITY => undef, |
621
|
9
|
100
|
|
|
|
237
|
UNIQUE_OR_PRIMARY => $table_info{$row->{table}}{columns}{$row->{to}} ? 'PRIMARY' : 'UNIQUE', |
622
|
|
|
|
|
|
|
}; |
623
|
|
|
|
|
|
|
} |
624
|
|
|
|
|
|
|
} |
625
|
|
|
|
|
|
|
} |
626
|
|
|
|
|
|
|
|
627
|
6
|
50
|
|
|
|
27
|
my $sponge_dbh = DBI->connect("DBI:Sponge:", "", "") |
628
|
|
|
|
|
|
|
or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); |
629
|
|
|
|
|
|
|
my $sponge_sth = $sponge_dbh->prepare("foreign_key_info", { |
630
|
|
|
|
|
|
|
NAME => \@FOREIGN_KEY_INFO_ODBC, |
631
|
6
|
50
|
|
|
|
3159
|
rows => [ map { [@{$_}{@FOREIGN_KEY_INFO_ODBC} ] } @fk_info ], |
|
9
|
|
|
|
|
14
|
|
|
9
|
|
|
|
|
62
|
|
632
|
|
|
|
|
|
|
NUM_OF_FIELDS => scalar(@FOREIGN_KEY_INFO_ODBC), |
633
|
|
|
|
|
|
|
}) or return $dbh->DBI::set_err( |
634
|
|
|
|
|
|
|
$sponge_dbh->err, |
635
|
|
|
|
|
|
|
$sponge_dbh->errstr, |
636
|
|
|
|
|
|
|
); |
637
|
6
|
|
|
|
|
642
|
return $sponge_sth; |
638
|
|
|
|
|
|
|
} |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
my @STATISTICS_INFO_ODBC = ( |
641
|
|
|
|
|
|
|
'TABLE_CAT', # The catalog identifier. |
642
|
|
|
|
|
|
|
'TABLE_SCHEM', # The schema identifier. |
643
|
|
|
|
|
|
|
'TABLE_NAME', # The table identifier. |
644
|
|
|
|
|
|
|
'NON_UNIQUE', # Unique index indicator. |
645
|
|
|
|
|
|
|
'INDEX_QUALIFIER', # Index qualifier identifier. |
646
|
|
|
|
|
|
|
'INDEX_NAME', # The index identifier. |
647
|
|
|
|
|
|
|
'TYPE', # The type of information being returned. |
648
|
|
|
|
|
|
|
'ORDINAL_POSITION', # Column sequence number (starting with 1). |
649
|
|
|
|
|
|
|
'COLUMN_NAME', # The column identifier. |
650
|
|
|
|
|
|
|
'ASC_OR_DESC', # Column sort sequence. |
651
|
|
|
|
|
|
|
'CARDINALITY', # Cardinality of the table or index. |
652
|
|
|
|
|
|
|
'PAGES', # Number of storage pages used by this table or index. |
653
|
|
|
|
|
|
|
'FILTER_CONDITION', # The index filter condition as a string. |
654
|
|
|
|
|
|
|
); |
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
sub statistics_info { |
657
|
4
|
|
|
4
|
|
41203
|
my ($dbh, $catalog, $schema, $table, $unique_only, $quick) = @_; |
658
|
|
|
|
|
|
|
|
659
|
4
|
50
|
|
|
|
95
|
my $databases = $dbh->selectall_arrayref("PRAGMA database_list", {Slice => {}}) or return; |
660
|
|
|
|
|
|
|
|
661
|
4
|
|
|
|
|
506
|
my @statistics_info; |
662
|
4
|
|
|
|
|
12
|
for my $database (@$databases) { |
663
|
8
|
|
|
|
|
22
|
my $dbname = $database->{name}; |
664
|
8
|
0
|
33
|
|
|
26
|
next if defined $schema && $schema ne '%' && $schema ne $dbname; |
|
|
|
33
|
|
|
|
|
665
|
|
|
|
|
|
|
|
666
|
8
|
|
|
|
|
49
|
my $quoted_dbname = $dbh->quote_identifier($dbname); |
667
|
8
|
50
|
|
|
|
245
|
my $master_table = |
|
|
100
|
|
|
|
|
|
668
|
|
|
|
|
|
|
($dbname eq 'main') ? 'sqlite_master' : |
669
|
|
|
|
|
|
|
($dbname eq 'temp') ? 'sqlite_temp_master' : |
670
|
|
|
|
|
|
|
$quoted_dbname.'.sqlite_master'; |
671
|
|
|
|
|
|
|
|
672
|
8
|
50
|
|
|
|
49
|
my $tables = $dbh->selectall_arrayref("SELECT name FROM $master_table WHERE type = ?", undef, "table") or return; |
673
|
8
|
|
|
|
|
109
|
for my $table_ref (@$tables) { |
674
|
8
|
|
|
|
|
21
|
my $tbname = $table_ref->[0]; |
675
|
8
|
100
|
33
|
|
|
68
|
next if defined $table && $table ne '%' && uc($table) ne uc($tbname); |
|
|
|
66
|
|
|
|
|
676
|
|
|
|
|
|
|
|
677
|
4
|
|
|
|
|
19
|
my $quoted_tbname = $dbh->quote_identifier($tbname); |
678
|
4
|
50
|
|
|
|
125
|
my $sth = $dbh->prepare("PRAGMA $quoted_dbname.index_list($quoted_tbname)") or return; |
679
|
4
|
50
|
|
|
|
43
|
$sth->execute or return; |
680
|
4
|
|
|
|
|
105
|
while(my $row = $sth->fetchrow_hashref) { |
681
|
|
|
|
|
|
|
|
682
|
16
|
100
|
100
|
|
|
137
|
next if $unique_only && !$row->{unique}; |
683
|
12
|
|
|
|
|
46
|
my $quoted_idx = $dbh->quote_identifier($row->{name}); |
684
|
12
|
|
|
|
|
325
|
for my $db (@$databases) { |
685
|
24
|
|
|
|
|
88
|
my $quoted_db = $dbh->quote_identifier($db->{name}); |
686
|
24
|
50
|
|
|
|
718
|
my $i_sth = $dbh->prepare("PRAGMA $quoted_db.index_info($quoted_idx)") or return; |
687
|
24
|
50
|
|
|
|
183
|
$i_sth->execute or return; |
688
|
24
|
|
|
|
|
55
|
my $cols = {}; |
689
|
24
|
|
|
|
|
651
|
while(my $info = $i_sth->fetchrow_hashref) { |
690
|
|
|
|
|
|
|
push @statistics_info, { |
691
|
|
|
|
|
|
|
TABLE_CAT => undef, |
692
|
|
|
|
|
|
|
TABLE_SCHEM => $db->{name}, |
693
|
|
|
|
|
|
|
TABLE_NAME => $tbname, |
694
|
|
|
|
|
|
|
NON_UNIQUE => $row->{unique} ? 0 : 1, |
695
|
|
|
|
|
|
|
INDEX_QUALIFIER => undef, |
696
|
|
|
|
|
|
|
INDEX_NAME => $row->{name}, |
697
|
|
|
|
|
|
|
TYPE => 'btree', # see http://www.sqlite.org/version3.html esp. "Traditional B-trees are still used for indices" |
698
|
|
|
|
|
|
|
ORDINAL_POSITION => $info->{seqno} + 1, |
699
|
|
|
|
|
|
|
COLUMN_NAME => $info->{name}, |
700
|
16
|
100
|
|
|
|
424
|
ASC_OR_DESC => undef, |
701
|
|
|
|
|
|
|
CARDINALITY => undef, |
702
|
|
|
|
|
|
|
PAGES => undef, |
703
|
|
|
|
|
|
|
FILTER_CONDITION => undef, |
704
|
|
|
|
|
|
|
}; |
705
|
|
|
|
|
|
|
} |
706
|
|
|
|
|
|
|
} |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
} |
709
|
|
|
|
|
|
|
} |
710
|
|
|
|
|
|
|
|
711
|
4
|
50
|
|
|
|
23
|
my $sponge_dbh = DBI->connect("DBI:Sponge:", "", "") |
712
|
|
|
|
|
|
|
or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); |
713
|
|
|
|
|
|
|
my $sponge_sth = $sponge_dbh->prepare("statistics_info", { |
714
|
|
|
|
|
|
|
NAME => \@STATISTICS_INFO_ODBC, |
715
|
4
|
50
|
|
|
|
3112
|
rows => [ map { [@{$_}{@STATISTICS_INFO_ODBC} ] } @statistics_info ], |
|
16
|
|
|
|
|
30
|
|
|
16
|
|
|
|
|
153
|
|
716
|
|
|
|
|
|
|
NUM_OF_FIELDS => scalar(@STATISTICS_INFO_ODBC), |
717
|
|
|
|
|
|
|
}) or return $dbh->DBI::set_err( |
718
|
|
|
|
|
|
|
$sponge_dbh->err, |
719
|
|
|
|
|
|
|
$sponge_dbh->errstr, |
720
|
|
|
|
|
|
|
); |
721
|
4
|
|
|
|
|
609
|
return $sponge_sth; |
722
|
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
sub type_info_all { |
725
|
0
|
|
|
0
|
|
0
|
return; # XXX code just copied from DBD::Oracle, not yet thought about |
726
|
|
|
|
|
|
|
} |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
my @COLUMN_INFO = qw( |
729
|
|
|
|
|
|
|
TABLE_CAT |
730
|
|
|
|
|
|
|
TABLE_SCHEM |
731
|
|
|
|
|
|
|
TABLE_NAME |
732
|
|
|
|
|
|
|
COLUMN_NAME |
733
|
|
|
|
|
|
|
DATA_TYPE |
734
|
|
|
|
|
|
|
TYPE_NAME |
735
|
|
|
|
|
|
|
COLUMN_SIZE |
736
|
|
|
|
|
|
|
BUFFER_LENGTH |
737
|
|
|
|
|
|
|
DECIMAL_DIGITS |
738
|
|
|
|
|
|
|
NUM_PREC_RADIX |
739
|
|
|
|
|
|
|
NULLABLE |
740
|
|
|
|
|
|
|
REMARKS |
741
|
|
|
|
|
|
|
COLUMN_DEF |
742
|
|
|
|
|
|
|
SQL_DATA_TYPE |
743
|
|
|
|
|
|
|
SQL_DATETIME_SUB |
744
|
|
|
|
|
|
|
CHAR_OCTET_LENGTH |
745
|
|
|
|
|
|
|
ORDINAL_POSITION |
746
|
|
|
|
|
|
|
IS_NULLABLE |
747
|
|
|
|
|
|
|
); |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
sub column_info { |
750
|
7
|
|
|
7
|
|
5165
|
my ($dbh, $cat_val, $sch_val, $tbl_val, $col_val) = @_; |
751
|
|
|
|
|
|
|
|
752
|
7
|
100
|
100
|
|
|
61
|
if ( defined $col_val and $col_val eq '%' ) { |
753
|
1
|
|
|
|
|
3
|
$col_val = undef; |
754
|
|
|
|
|
|
|
} |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
# Get a list of all tables ordered by TABLE_SCHEM, TABLE_NAME |
757
|
7
|
|
|
|
|
17
|
my $sql = <<'END_SQL'; |
758
|
|
|
|
|
|
|
SELECT TABLE_SCHEM, tbl_name TABLE_NAME |
759
|
|
|
|
|
|
|
FROM ( |
760
|
|
|
|
|
|
|
SELECT 'main' TABLE_SCHEM, tbl_name |
761
|
|
|
|
|
|
|
FROM sqlite_master |
762
|
|
|
|
|
|
|
WHERE type IN ('table','view') |
763
|
|
|
|
|
|
|
UNION ALL |
764
|
|
|
|
|
|
|
SELECT 'temp' TABLE_SCHEM, tbl_name |
765
|
|
|
|
|
|
|
FROM sqlite_temp_master |
766
|
|
|
|
|
|
|
WHERE type IN ('table','view') |
767
|
|
|
|
|
|
|
END_SQL |
768
|
|
|
|
|
|
|
|
769
|
7
|
|
|
|
|
23
|
for my $db_name (_attached_database_list($dbh)) { |
770
|
2
|
|
|
|
|
10
|
$sql .= <<"END_SQL"; |
771
|
|
|
|
|
|
|
UNION ALL |
772
|
|
|
|
|
|
|
SELECT '$db_name' TABLE_SCHEM, tbl_name |
773
|
|
|
|
|
|
|
FROM "$db_name".sqlite_master |
774
|
|
|
|
|
|
|
WHERE type IN ('table','view') |
775
|
|
|
|
|
|
|
END_SQL |
776
|
|
|
|
|
|
|
} |
777
|
|
|
|
|
|
|
|
778
|
7
|
|
|
|
|
20
|
$sql .= <<'END_SQL'; |
779
|
|
|
|
|
|
|
UNION ALL |
780
|
|
|
|
|
|
|
SELECT 'main' TABLE_SCHEM, 'sqlite_master' tbl_name |
781
|
|
|
|
|
|
|
UNION ALL |
782
|
|
|
|
|
|
|
SELECT 'temp' TABLE_SCHEM, 'sqlite_temp_master' tbl_name |
783
|
|
|
|
|
|
|
) |
784
|
|
|
|
|
|
|
END_SQL |
785
|
|
|
|
|
|
|
|
786
|
7
|
|
|
|
|
10
|
my @where; |
787
|
7
|
50
|
|
|
|
22
|
if (defined $sch_val) { |
788
|
0
|
|
|
|
|
0
|
push @where, "TABLE_SCHEM LIKE '$sch_val'"; |
789
|
|
|
|
|
|
|
} |
790
|
7
|
50
|
|
|
|
19
|
if (defined $tbl_val) { |
791
|
7
|
|
|
|
|
23
|
push @where, "TABLE_NAME LIKE '$tbl_val'"; |
792
|
|
|
|
|
|
|
} |
793
|
7
|
50
|
|
|
|
52
|
$sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where; |
794
|
7
|
|
|
|
|
16
|
$sql .= " ORDER BY TABLE_SCHEM, TABLE_NAME\n"; |
795
|
7
|
50
|
|
|
|
34
|
my $sth_tables = $dbh->prepare($sql) or return undef; |
796
|
7
|
50
|
|
|
|
612
|
$sth_tables->execute or return undef; |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
# Taken from Fey::Loader::SQLite |
799
|
7
|
|
|
|
|
32
|
my @cols; |
800
|
7
|
|
|
|
|
125
|
while (my($schema, $table) = $sth_tables->fetchrow_array) { |
801
|
9
|
50
|
|
|
|
58
|
my $sth_columns = $dbh->prepare(qq{PRAGMA "$schema".table_info("$table")}) or return; |
802
|
9
|
50
|
|
|
|
84
|
$sth_columns->execute or return; |
803
|
|
|
|
|
|
|
|
804
|
9
|
|
|
|
|
190
|
for (my $position = 1; my $col_info = $sth_columns->fetchrow_hashref; $position++) { |
805
|
20
|
100
|
|
|
|
56
|
if (defined $col_val) { |
806
|
|
|
|
|
|
|
# This must do a LIKE comparison |
807
|
14
|
50
|
|
|
|
86
|
my $sth = $dbh->prepare("SELECT '$col_info->{name}' LIKE '$col_val'") or return undef; |
808
|
14
|
50
|
|
|
|
161
|
$sth->execute or return undef; |
809
|
|
|
|
|
|
|
# Skip columns that don't match $col_val |
810
|
14
|
100
|
|
|
|
354
|
next unless ($sth->fetchrow_array)[0]; |
811
|
|
|
|
|
|
|
} |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
my %col = ( |
814
|
|
|
|
|
|
|
TABLE_SCHEM => $schema, |
815
|
|
|
|
|
|
|
TABLE_NAME => $table, |
816
|
|
|
|
|
|
|
COLUMN_NAME => $col_info->{name}, |
817
|
13
|
|
|
|
|
70
|
ORDINAL_POSITION => $position, |
818
|
|
|
|
|
|
|
); |
819
|
|
|
|
|
|
|
|
820
|
13
|
|
|
|
|
35
|
my $type = $col_info->{type}; |
821
|
13
|
100
|
|
|
|
102
|
if ($type =~ s/(\w+)\s*\(\s*(\d+)(?:\s*,\s*(\d+))?\s*\)/$1/) { |
822
|
7
|
|
|
|
|
19
|
$col{COLUMN_SIZE} = $2; |
823
|
7
|
|
|
|
|
16
|
$col{DECIMAL_DIGITS} = $3; |
824
|
|
|
|
|
|
|
} |
825
|
|
|
|
|
|
|
|
826
|
13
|
|
|
|
|
34
|
$col{TYPE_NAME} = $type; |
827
|
|
|
|
|
|
|
|
828
|
13
|
50
|
|
|
|
32
|
if ( defined $col_info->{dflt_value} ) { |
829
|
|
|
|
|
|
|
$col{COLUMN_DEF} = $col_info->{dflt_value} |
830
|
0
|
|
|
|
|
0
|
} |
831
|
|
|
|
|
|
|
|
832
|
13
|
100
|
|
|
|
30
|
if ( $col_info->{notnull} ) { |
833
|
2
|
|
|
|
|
7
|
$col{NULLABLE} = 0; |
834
|
2
|
|
|
|
|
13
|
$col{IS_NULLABLE} = 'NO'; |
835
|
|
|
|
|
|
|
} else { |
836
|
11
|
|
|
|
|
23
|
$col{NULLABLE} = 1; |
837
|
11
|
|
|
|
|
17
|
$col{IS_NULLABLE} = 'YES'; |
838
|
|
|
|
|
|
|
} |
839
|
|
|
|
|
|
|
|
840
|
13
|
|
|
|
|
209
|
push @cols, \%col; |
841
|
|
|
|
|
|
|
} |
842
|
9
|
|
|
|
|
162
|
$sth_columns->finish; |
843
|
|
|
|
|
|
|
} |
844
|
7
|
|
|
|
|
28
|
$sth_tables->finish; |
845
|
|
|
|
|
|
|
|
846
|
7
|
50
|
|
|
|
36
|
my $sponge = DBI->connect("DBI:Sponge:", '','') |
847
|
|
|
|
|
|
|
or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); |
848
|
|
|
|
|
|
|
$sponge->prepare( "column_info", { |
849
|
7
|
50
|
|
|
|
7963
|
rows => [ map { [ @{$_}{@COLUMN_INFO} ] } @cols ], |
|
13
|
|
|
|
|
25
|
|
|
13
|
|
|
|
|
167
|
|
850
|
|
|
|
|
|
|
NUM_OF_FIELDS => scalar @COLUMN_INFO, |
851
|
|
|
|
|
|
|
NAME => [ @COLUMN_INFO ], |
852
|
|
|
|
|
|
|
} ) or return $dbh->DBI::set_err( |
853
|
|
|
|
|
|
|
$sponge->err, |
854
|
|
|
|
|
|
|
$sponge->errstr, |
855
|
|
|
|
|
|
|
); |
856
|
|
|
|
|
|
|
} |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
#====================================================================== |
859
|
|
|
|
|
|
|
# An internal tied hash package used for %DBD::SQLeet::COLLATION, to |
860
|
|
|
|
|
|
|
# prevent people from unintentionally overriding globally registered collations. |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
package # hide from PAUSE |
863
|
|
|
|
|
|
|
DBD::SQLeet::_WriteOnceHash; |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
require Tie::Hash; |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
our @ISA = qw(Tie::StdHash); |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
sub TIEHASH { |
870
|
101
|
|
|
101
|
|
481
|
bless {}, $_[0]; |
871
|
|
|
|
|
|
|
} |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
sub STORE { |
874
|
207
|
100
|
|
207
|
|
1961
|
! exists $_[0]->{$_[1]} or die "entry $_[1] already registered"; |
875
|
205
|
|
|
|
|
707
|
$_[0]->{$_[1]} = $_[2]; |
876
|
|
|
|
|
|
|
} |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
sub DELETE { |
879
|
1
|
|
|
1
|
|
453
|
die "deletion of entry $_[1] is forbidden"; |
880
|
|
|
|
|
|
|
} |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
1; |
883
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
__END__ |