Skip Menu |
 

This queue is for tickets about the DBIx-Class CPAN distribution.

Report information
The Basics
Id: 81066
Status: open
Priority: 0/
Queue: DBIx-Class

People
Owner: Nobody in particular
Requestors: TAUNGER [...] cpan.org
Cc:
AdminCc:

Bug Information
Severity: Wishlist
Broken in: (no value)
Fixed in: (no value)



Subject: BLOB Support for SQLite with sqlite_unicode = 1
I need blob support with SQLite in one of my projects. sqlite_unicode is active, so DBD::SQLite can only store blobs with the explicit bind_param: my $sth = $dbh->prepare("INSERT INTO mytable VALUES (1, ?)"); $sth->bind_param(1, $blob, SQL_BLOB); $sth->execute(); (as described in DBD::SQLite) --- the following path works fine (for me) --- SQLite_new.pm Fri Nov 09 09:29:55 2012 +++ C:\Temp\DBIx-Class-0.08204\lib\DBIx\Class\Storage\DBI\SQLite.pm Fri Nov 09 09:26:28 2012 @@ -189,11 +189,16 @@ $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest); } +use DBI qw(); sub bind_attribute_by_data_type { - $_[1] =~ /^ (?: int(?:eger)? | (?:tiny|small|medium)int ) $/ix - ? do { require DBI; DBI::SQL_INTEGER() } - : undef - ; + + return DBI::SQL_INTEGER( ) + if $_[1] =~ /^ (?: int(?:eger)? | (?:tiny|small|medium)int ) $/ix; + + return DBI::SQL_BLOB( ) + if $_[1] =~ /^blob|bytea$/i; # more? include clob? + + return undef; } # DBD::SQLite (at least up to version 1.31 has a bug where it will ---
Can we please get some extra tests with that? t/752sqlite.t would be a good sarting point. Cheers
Download (untitled) / with headers
text/plain 1.7k
I have modified the "blob test" from 750firebird.t The test-suite passed (without tests which require a special environment). --- C:\Temp\DBIx-Class-0.08204\t\752sqlite.t Thu Nov 08 20:41:11 2012 +++ 752sqlite.t Fri Nov 09 12:23:09 2012 @@ -169,6 +169,61 @@ } } +# test blobs - stolen from 750firebird.t + + my $dbh = $schema->storage->dbh; + + $dbh->{sqlite_unicode} = 1; # turn on unicode + + eval { $dbh->do('DROP TABLE "bindtype_test"') }; + $dbh->do(q[ + CREATE TABLE "bindtype_test" + ( + "id" INT PRIMARY KEY, + "bytea" INT, + "blob" BLOB, + "clob" BLOB SUB_TYPE TEXT, + "a_memo" INT + ) + ]); + + my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); + $binstr{'large'} = $binstr{'small'} x 1024; + + # we don't need this for SQLite +# my $maxloblen = length $binstr{'large'}; +# local $dbh->{'LongReadLen'} = $maxloblen; + + my $rs = $schema->resultset('BindType'); + my $id = 0; + + foreach my $type (qw( blob)) { + foreach my $size (qw( small large )) { + $id++; + +# turn off horrendous binary DBIC_TRACE output + local $schema->storage->{debug} = 0; + + lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) } + "inserted $size $type without dying"; + + my $got = $rs->find($id)->$type; + + my $hexdump = sub { join '', map sprintf('%02X', ord), split //, shift }; + + ok($got eq $binstr{$size}, "verified inserted $size $type" ) + or do { + diag "For " . (ref $schema->storage) . "\n"; + diag "Got blob:\n"; + diag $hexdump->(substr($got,0,50)); + diag "Expecting blob:\n"; + diag $hexdump->(substr($binstr{$size},0,50)); + }; + } + } + + $dbh->{sqlite_unicode} = 0; + done_testing; # vim:sts=2 sw=2:
Subject: 752sqlite.t
Download 752sqlite.t
text/x-perl 6.9k
use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use Time::HiRes 'time'; use Config; use lib qw(t/lib); use DBICTest; # savepoints test { my $schema = DBICTest->init_schema(auto_savepoint => 1); my $ars = $schema->resultset('Artist'); # test two-phase commit and inner transaction rollback from nested transactions $schema->txn_do(sub { $ars->create({ name => 'in_outer_transaction' }); $schema->txn_do(sub { $ars->create({ name => 'in_inner_transaction' }); }); ok($ars->search({ name => 'in_inner_transaction' })->first, 'commit from inner transaction visible in outer transaction'); throws_ok { $schema->txn_do(sub { $ars->create({ name => 'in_inner_transaction_rolling_back' }); die 'rolling back inner transaction'; }); } qr/rolling back inner transaction/, 'inner transaction rollback executed'; $ars->create({ name => 'in_outer_transaction2' }); }); ok($ars->search({ name => 'in_outer_transaction' })->first, 'commit from outer transaction'); ok($ars->search({ name => 'in_outer_transaction2' })->first, 'second commit from outer transaction'); ok($ars->search({ name => 'in_inner_transaction' })->first, 'commit from inner transaction'); is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first, undef, 'rollback from inner transaction'; } # check that we work somewhat OK with braindead SQLite transaction handling # # As per https://metacpan.org/source/ADAMK/DBD-SQLite-1.37/lib/DBD/SQLite.pm#L921 # SQLite does *not* try to synchronize for my $prefix_comment (qw/Begin_only Commit_only Begin_and_Commit/) { note "Testing with comment prefixes on $prefix_comment"; # FIXME warning won't help us for the time being # perhaps when (if ever) DBD::SQLite gets fixed, # we can do something extra here local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /Internal transaction state .+? does not seem to match/ } unless $ENV{TEST_VERBOSE}; my ($c_begin, $c_commit) = map { $prefix_comment =~ $_ ? 1 : 0 } (qr/Begin/, qr/Commit/); my $schema = DBICTest->init_schema( no_deploy => 1 ); my $ars = $schema->resultset('Artist'); ok (! $schema->storage->connected, 'No connection yet'); $schema->storage->dbh->do(<<'DDL'); CREATE TABLE artist ( artistid INTEGER PRIMARY KEY NOT NULL, name varchar(100), rank integer DEFAULT 13, charfield char(10) NULL ); DDL my $artist = $ars->create({ name => 'Artist_' . time() }); is ($ars->count, 1, 'Inserted artist ' . $artist->name); ok ($schema->storage->connected, 'Connected'); ok ($schema->storage->_dbh->{AutoCommit}, 'DBD not in txn yet'); $schema->storage->dbh->do(join "\n", $c_begin ? '-- comment' : (), 'BEGIN TRANSACTION' ); ok ($schema->storage->connected, 'Still connected'); { local $TODO = 'SQLite is retarded wrt detecting BEGIN' if $c_begin; ok (! $schema->storage->_dbh->{AutoCommit}, "DBD aware of txn begin with comments on $prefix_comment"); } $schema->storage->dbh->do(join "\n", $c_commit ? '-- comment' : (), 'COMMIT' ); ok ($schema->storage->connected, 'Still connected'); { local $TODO = 'SQLite is retarded wrt detecting COMMIT' if $c_commit; ok ($schema->storage->_dbh->{AutoCommit}, "DBD aware txn ended with comments on $prefix_comment"); } is ($ars->count, 1, 'Inserted artists still there'); { # this never worked in the 1st place local $TODO = 'SQLite is retarded wrt detecting COMMIT' if ! $c_begin and $c_commit; # odd argument passing, because such nested crefs leak on 5.8 lives_ok { $schema->storage->txn_do (sub { ok ($_[0]->find({ name => $_[1] }), "Artist still where we left it after cycle with comments on $prefix_comment"); }, $ars, $artist->name ); } "Succesfull transaction with comments on $prefix_comment"; } } my $schema = DBICTest->init_schema(); # make sure the side-effects of RT#67581 do not result in data loss my $row; warnings_exist { $row = $schema->resultset('Artist')->create ({ name => 'alpha rank', rank => 'abc' }) } [qr/Non-numeric value supplied for column 'rank' despite the numeric datatype/], 'proper warning on string insertion into an numeric column' ; $row->discard_changes; is ($row->rank, 'abc', 'proper rank inserted into database'); # and make sure we do not lose actual bigints { package DBICTest::BigIntArtist; use base 'DBICTest::Schema::Artist'; __PACKAGE__->table('artist'); __PACKAGE__->add_column(bigint => { data_type => 'bigint' }); } $schema->register_class(BigIntArtist => 'DBICTest::BigIntArtist'); $schema->storage->dbh_do(sub { $_[1]->do('ALTER TABLE artist ADD COLUMN bigint BIGINT'); }); # test upper/lower boundaries for sqlite and some values inbetween # range is -(2**63) .. 2**63 - 1 SKIP: { skip 'This perl does not seem to have 64bit int support - DBI roundtrip of large int will fail with DBD::SQLite < 1.37', 1 if ($Config{ivsize} < 8 and ! eval { DBD::SQLite->VERSION(1.37); 1 }); for my $bi (qw/ -9223372036854775808 -9223372036854775807 -8694837494948124658 -6848440844435891639 -5664812265578554454 -5380388020020483213 -2564279463598428141 2442753333597784273 4790993557925631491 6773854980030157393 7627910776496326154 8297530189347439311 9223372036854775806 9223372036854775807 /) { $row = $schema->resultset('BigIntArtist')->create({ bigint => $bi }); is ($row->bigint, $bi, "value in object correct ($bi)"); $row->discard_changes; is ($row->bigint, $bi, "value in database correct ($bi)"); } } # test blobs - stolen from 750firebird.t my $dbh = $schema->storage->dbh; $dbh->{sqlite_unicode} = 1; # turn on unicode eval { $dbh->do('DROP TABLE "bindtype_test"') }; $dbh->do(q[ CREATE TABLE "bindtype_test" ( "id" INT PRIMARY KEY, "bytea" INT, "blob" BLOB, "clob" BLOB SUB_TYPE TEXT, "a_memo" INT ) ]); my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); $binstr{'large'} = $binstr{'small'} x 1024; # we don't need this for SQLite # my $maxloblen = length $binstr{'large'}; # local $dbh->{'LongReadLen'} = $maxloblen; my $rs = $schema->resultset('BindType'); my $id = 0; foreach my $type (qw( blob)) { foreach my $size (qw( small large )) { $id++; # turn off horrendous binary DBIC_TRACE output local $schema->storage->{debug} = 0; lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) } "inserted $size $type without dying"; my $got = $rs->find($id)->$type; my $hexdump = sub { join '', map sprintf('%02X', ord), split //, shift }; ok($got eq $binstr{$size}, "verified inserted $size $type" ) or do { diag "For " . (ref $schema->storage) . "\n"; diag "Got blob:\n"; diag $hexdump->(substr($got,0,50)); diag "Expecting blob:\n"; diag $hexdump->(substr($binstr{$size},0,50)); }; } } $dbh->{sqlite_unicode} = 0; done_testing; # vim:sts=2 sw=2:
Download (untitled) / with headers
text/plain 142b
Looks about right, will be applied shortly with minor modifications. In the future consider sending a github pullreq or git-formatted patches.
Ah, Thank You Next time i'm using the git-mode for the patch... or do a pull request. Sorry
Download (untitled) / with headers
text/plain 367b
On Fri Nov 09 06:38:58 2012, TAUNGER wrote: Show quoted text
> I have modified the "blob test" from 750firebird.t >
I finally had a chance to look at this - there is a problem with the test. It passes even without changes to ::Storage::SQLite. I fiddled with it for a while but could not produce a failing test. Can you please look into this and let me know what is missing? Cheers
Download (untitled) / with headers
text/plain 1.9k
On Thu Dec 27 01:45:30 2012, RIBASUSHI wrote: Show quoted text
> On Fri Nov 09 06:38:58 2012, TAUNGER wrote:
> > I have modified the "blob test" from 750firebird.t > >
> > I finally had a chance to look at this - there is a problem with the > test. It passes even without changes to ::Storage::SQLite. I fiddled > with it for a while but could not produce a failing test. Can you please > look into this and let me know what is missing? >
These are my simplifications so far: ============ use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use Time::HiRes 'time'; use Config; use lib qw(t/lib); use DBICTest; ... # test blobs - stolen from 750firebird.t { my $schema = DBICTest->init_schema( no_deploy => 1, sqlite_unicode => 1 ); my $dbh = $schema->storage->dbh; ok( $dbh->{sqlite_unicode}, 'Unicode is on on $dbh' ); $dbh->do(q[ CREATE TABLE "bindtype_test" ( "id" INT PRIMARY KEY, "blob" BLOB, "clob" BLOB SUB_TYPE TEXT ) ]); my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 255 )) ); $binstr{'large'} = $binstr{'small'} x 1024; my $rs = $schema->resultset('BindType'); my $id = 0; foreach my $type (qw( blob clob )) { foreach my $size (qw( small large )) { $id++; # turn off horrendous binary DBIC_TRACE output local $schema->storage->{debug} = 0; lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) } "inserted $size $type without dying"; my $got = $rs->find($id, { columns => ['id', $type] })->$type; my $hexdump = sub { join '', map sprintf('%02X', ord), split //, shift }; ok($got eq $binstr{$size}, "verified inserted $size $type" ) or do { diag "For " . (ref $schema->storage) . "\n"; diag "Got blob:\n"; diag $hexdump->(substr($got,0,50)); diag "Expecting blob:\n"; diag $hexdump->(substr($binstr{$size},0,50)); }; } } } done_testing;
Download (untitled) / with headers
text/plain 2.3k
Ok, i think i've got the problem. We are only checking if the retrieved data is the same as the stored. In fact, it is the same. I can print the blob to a filehandle and everything looks fine. The only real world problem i've found is the one which leads me to this ticket. I want to load a Wx::Image directly from the database (=> from an internal scalar). Something like this: ########################## use 5.16.0; use warnings; use My::Schema; use Wx qw( :everything ); Wx::InitAllImageHandlers(); my $schema = My::Schema->connect( 'dbi:SQLite:dbname=test.db', '', '', { RaiseError => 1, sqlite_unicode => 1 } ); open my $fh, '<', 'test.ico' or die $!; binmode $fh; my $testicon = do { local $/; <$fh> }; close $fh; open $fh, '<', \$testicon or die $!; binmode $fh; my $image = Wx::Image->new( $fh, wxBITMAP_TYPE_ICO ); close $fh; say 'image loading from internal fh: ' . $image->IsOk; # ok my $id = $schema->resultset( 'Icon' )->create( { command_id => 1, icon => $testicon, } )->id; my $rs = $schema->resultset( 'Icon' )->find( $id ); my $test = $rs->icon; say utf8::is_utf8( $test ); # 1 say 'equal: ' . ( $testicon eq $test ); # 1 - thats odd, perl seems to ignore the utf8 flag in some functions open $fh, '<', \$test or die $!; binmode $fh; $image = Wx::Image->new( $fh, wxBITMAP_TYPE_ICO ); close $fh; say 'database load: ' . $image->IsOk; # fails utf8::decode($test); # manually remove the flag say utf8::is_utf8( $test ); # 0 open $fh, '<', \$test or die $!; binmode $fh; $image = Wx::Image->new( $fh, wxBITMAP_TYPE_ICO ); close $fh; say 'database load: ' . $image->IsOk; # now it's fine again $rs->delete; ########################## As you can see, it appears that the problem is the utf8-flag. According to http://search.cpan.org/~adamk/DBD-SQLite-1.37/lib/DBD/SQLite.pm#Unicode_handling every __string__ from the database is utf8-tagged. If no explicit bind type is used, the field value is treated as a string. Which is wrong in our case with the blob. Back to you question, you can bring your test to fail (and pass with the patch) if you add the following line ### isnt( utf8::is_utf8( $got ), 1, "binary data ( $type, $size ) is wrongly utf8 tagged" ); ### under ### my $got = $rs->find($id, { columns => ['id', $type] })->$type; ### However, you can use this test only for binary data. If you add non-tagged non-blob data to a sqlite_unicode database it is always returned with the flag enabled.


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.