I was wrong about 2d12a809 - the crash is real
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI / SQLite.pm
CommitLineData
843f8ecd 1package DBIx::Class::Storage::DBI::SQLite;
2
3use strict;
4use warnings;
2ad62d97 5
6use base qw/DBIx::Class::Storage::DBI/;
7use mro 'c3';
8
632d1e0f 9use DBIx::Class::Carp;
10use Scalar::Util 'looks_like_number';
8d1fb3e2 11use Try::Tiny;
632d1e0f 12use namespace::clean;
13
d5dedbd6 14__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::SQLite');
6a247f33 15__PACKAGE__->sql_limit_dialect ('LimitOffset');
2b8cc2f2 16__PACKAGE__->sql_quote_char ('"');
6f7a118e 17__PACKAGE__->datetime_parser_type ('DateTime::Format::SQLite');
09cedb88 18
2fa97c7d 19=head1 NAME
20
21DBIx::Class::Storage::DBI::SQLite - Automatic primary key class for SQLite
22
23=head1 SYNOPSIS
24
25 # In your table classes
26 use base 'DBIx::Class::Core';
27 __PACKAGE__->set_primary_key('id');
28
29=head1 DESCRIPTION
30
31This class implements autoincrements for SQLite.
32
33=head1 METHODS
34
35=cut
36
357eb92c 37sub backup {
38
39 require File::Spec;
40 require File::Copy;
41 require POSIX;
42
8795fefb 43 my ($self, $dir) = @_;
44 $dir ||= './';
c9d2e0a2 45
46 ## Where is the db file?
12c9beea 47 my $dsn = $self->_dbi_connect_info()->[0];
c9d2e0a2 48
49 my $dbname = $1 if($dsn =~ /dbname=([^;]+)/);
50 if(!$dbname)
51 {
52 $dbname = $1 if($dsn =~ /^dbi:SQLite:(.+)$/i);
53 }
357eb92c 54 $self->throw_exception("Cannot determine name of SQLite db file")
c9d2e0a2 55 if(!$dbname || !-f $dbname);
56
57# print "Found database: $dbname\n";
79923569 58# my $dbfile = file($dbname);
8795fefb 59 my ($vol, $dbdir, $file) = File::Spec->splitpath($dbname);
79923569 60# my $file = $dbfile->basename();
357eb92c 61 $file = POSIX::strftime("%Y-%m-%d-%H_%M_%S", localtime()) . $file;
c9d2e0a2 62 $file = "B$file" while(-f $file);
8795fefb 63
64 mkdir($dir) unless -f $dir;
65 my $backupfile = File::Spec->catfile($dir, $file);
66
357eb92c 67 my $res = File::Copy::copy($dbname, $backupfile);
c9d2e0a2 68 $self->throw_exception("Backup failed! ($!)") if(!$res);
69
8795fefb 70 return $backupfile;
c9d2e0a2 71}
72
86a51471 73sub _exec_svp_begin {
74 my ($self, $name) = @_;
75
76 $self->_dbh->do("SAVEPOINT $name");
77}
78
79sub _exec_svp_release {
80 my ($self, $name) = @_;
81
82 $self->_dbh->do("RELEASE SAVEPOINT $name");
83}
84
85sub _exec_svp_rollback {
86 my ($self, $name) = @_;
87
88 # For some reason this statement changes the value of $dbh->{AutoCommit}, so
89 # we localize it here to preserve the original value.
90 local $self->_dbh->{AutoCommit} = $self->_dbh->{AutoCommit};
91
92 $self->_dbh->do("ROLLBACK TRANSACTION TO SAVEPOINT $name");
93}
94
8d1fb3e2 95sub _ping {
96 my $self = shift;
2aeb3c7f 97
98 # Be extremely careful what we do here. SQLite is notoriously bad at
99 # synchronizing its internal transaction state with {AutoCommit}
100 # https://metacpan.org/source/ADAMK/DBD-SQLite-1.37/lib/DBD/SQLite.pm#L921
101 # There is a function http://www.sqlite.org/c3ref/get_autocommit.html
102 # but DBD::SQLite does not expose it (nor does it seem to properly use it)
103
104 # Therefore only execute a "ping" when we have no other choice *AND*
105 # scrutinize the thrown exceptions to make sure we are where we think we are
106 my $dbh = $self->_dbh or return undef;
107 return undef unless $dbh->FETCH('Active');
108 return undef unless $dbh->ping;
109
110 # since we do not have access to sqlite3_get_autocommit(), do a trick
111 # to attempt to *safely* determine what state are we *actually* in.
112 # FIXME
113 # also using T::T here leads to bizarre leaks - will figure it out later
114 my $really_not_in_txn = do {
115 local $@;
116
117 # older versions of DBD::SQLite do not properly detect multiline BEGIN/COMMIT
118 # statements to adjust their {AutoCommit} state. Hence use such a statement
119 # pair here as well, in order to escape from poking {AutoCommit} needlessly
120 # https://rt.cpan.org/Public/Bug/Display.html?id=80087
121 eval {
122 # will fail instantly if already in a txn
123 $dbh->do("-- multiline\nBEGIN");
124 $dbh->do("-- multiline\nCOMMIT");
125 1;
126 } or do {
127 ($@ =~ /transaction within a transaction/)
128 ? 0
129 : undef
130 ;
131 };
132 };
133
134 my $ping_fail;
135
136 # if we were unable to determine this - we may very well be dead
137 if (not defined $really_not_in_txn) {
138 $ping_fail = 1;
139 }
140 # check the AC sync-state
141 elsif ($really_not_in_txn xor $dbh->{AutoCommit}) {
142 carp_unique (sprintf
143 'Internal transaction state of handle %s (apparently %s a transaction) does not seem to '
144 . 'match its AutoCommit attribute setting of %s - this is an indication of a '
145 . 'potentially serious bug in your transaction handling logic',
146 $dbh,
147 $really_not_in_txn ? 'NOT in' : 'in',
148 $dbh->{AutoCommit} ? 'TRUE' : 'FALSE',
149 );
150
151 # it is too dangerous to execute anything else in this state
152 # assume everything works (safer - worst case scenario next statement throws)
153 return 1;
154 }
155 else {
156 # do the actual test
157 $ping_fail = ! try { $dbh->do('SELECT * FROM sqlite_master LIMIT 1'); 1 };
158 }
159
160 if ($ping_fail) {
161 # it is possible to have a proper "connection", and have "ping" return
162 # false anyway (e.g. corrupted file). In such cases DBD::SQLite still
163 # keeps the actual file handle open. We don't really want this to happen,
164 # so force-close the handle via DBI itself
165 #
166 local $@; # so that we do not clober the real error as set above
167 eval { $dbh->disconnect }; # if it fails - it fails
168 return undef # the actual RV of _ping()
169 }
170 else {
171 return 1;
172 }
8d1fb3e2 173}
174
2361982d 175sub deployment_statements {
96736321 176 my $self = shift;
2361982d 177 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
178
179 $sqltargs ||= {};
180
96736321 181 if (
182 ! exists $sqltargs->{producer_args}{sqlite_version}
183 and
184 my $dver = $self->_server_info->{normalized_dbms_version}
185 ) {
186 $sqltargs->{producer_args}{sqlite_version} = $dver;
6d766626 187 }
2361982d 188
189 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
190}
191
0e773352 192sub bind_attribute_by_data_type {
67b35a45 193 $_[1] =~ /^ (?: int(?:eger)? | (?:tiny|small|medium)int ) $/ix
0e773352 194 ? do { require DBI; DBI::SQL_INTEGER() }
195 : undef
196 ;
197}
198
632d1e0f 199# DBD::SQLite (at least up to version 1.31 has a bug where it will
200# non-fatally nummify a string value bound as an integer, resulting
201# in insertions of '0' into supposed-to-be-numeric fields
202# Since this can result in severe data inconsistency, remove the
203# bind attr if such a sitation is detected
204#
205# FIXME - when a DBD::SQLite version is released that eventually fixes
206# this sutiation (somehow) - no-op this override once a proper DBD
207# version is detected
208sub _dbi_attrs_for_bind {
209 my ($self, $ident, $bind) = @_;
210 my $bindattrs = $self->next::method($ident, $bind);
211
212 for (0.. $#$bindattrs) {
213 if (
214 defined $bindattrs->[$_]
215 and
216 defined $bind->[$_][1]
217 and
218 $bindattrs->[$_] eq DBI::SQL_INTEGER()
219 and
220 ! looks_like_number ($bind->[$_][1])
221 ) {
222 carp_unique( sprintf (
223 "Non-numeric value supplied for column '%s' despite the numeric datatype",
224 $bind->[$_][0]{dbic_colname} || "# $_"
225 ) );
226 undef $bindattrs->[$_];
227 }
228 }
229
230 return $bindattrs;
231}
232
732e4282 233=head2 connect_call_use_foreign_keys
234
235Used as:
236
237 on_connect_call => 'use_foreign_keys'
238
8384a713 239In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to turn on foreign key
240(including cascading) support for recent versions of SQLite and L<DBD::SQLite>.
732e4282 241
242Executes:
243
8273e845 244 PRAGMA foreign_keys = ON
732e4282 245
246See L<http://www.sqlite.org/foreignkeys.html> for more information.
247
248=cut
249
250sub connect_call_use_foreign_keys {
251 my $self = shift;
252
253 $self->_do_query(
254 'PRAGMA foreign_keys = ON'
255 );
256}
257
843f8ecd 2581;
259
0c11ad0e 260=head1 AUTHOR AND CONTRIBUTORS
843f8ecd 261
0c11ad0e 262See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
843f8ecd 263
264=head1 LICENSE
265
266You may distribute this code under the same terms as Perl itself.
267
268=cut