r38683 - in /branches/upstream/liborlite-perl/current: Changes MANIFEST META.yml lib/ORLite.pm t/06_create.t t/07_pk.sql t/07_pk.t t/lib/Test.pm
bricas-guest at users.alioth.debian.org
bricas-guest at users.alioth.debian.org
Fri Jun 26 12:44:27 UTC 2009
Author: bricas-guest
Date: Fri Jun 26 12:44:09 2009
New Revision: 38683
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=38683
Log:
[svn-upgrade] Integrating new upstream version, liborlite-perl (1.23)
Added:
branches/upstream/liborlite-perl/current/t/07_pk.sql
branches/upstream/liborlite-perl/current/t/07_pk.t
Modified:
branches/upstream/liborlite-perl/current/Changes
branches/upstream/liborlite-perl/current/MANIFEST
branches/upstream/liborlite-perl/current/META.yml
branches/upstream/liborlite-perl/current/lib/ORLite.pm
branches/upstream/liborlite-perl/current/t/06_create.t
branches/upstream/liborlite-perl/current/t/lib/Test.pm
Modified: branches/upstream/liborlite-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/Changes?rev=38683&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/Changes (original)
+++ branches/upstream/liborlite-perl/current/Changes Fri Jun 26 12:44:09 2009
@@ -1,4 +1,9 @@
Changes for Perl extension ORLite
+
+1.23 Thu 11 Jun 2009
+ - Fixed a bug in method ->delete which deleted more than the actual
+ object in case the primary key consist of more than one column.
+ Added basic support for such primary keys with more than one column.
1.22 Mon 1 Jun 2009
- Updated to Module::Install::DSL 0.91
Modified: branches/upstream/liborlite-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/MANIFEST?rev=38683&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/MANIFEST (original)
+++ branches/upstream/liborlite-perl/current/MANIFEST Fri Jun 26 12:44:09 2009
@@ -23,6 +23,8 @@
t/04_readonly.t
t/05_notables.t
t/06_create.t
+t/07_pk.sql
+t/07_pk.t
t/97_meta.t
t/98_pod.t
t/99_pmv.t
Modified: branches/upstream/liborlite-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/META.yml?rev=38683&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/META.yml (original)
+++ branches/upstream/liborlite-perl/current/META.yml Fri Jun 26 12:44:09 2009
@@ -32,4 +32,4 @@
ChangeLog: http://fisheye2.atlassian.com/changelog/cpan/trunk/ORLite
license: http://dev.perl.org/licenses/
repository: http://svn.ali.as/cpan/trunk/ORLite
-version: 1.22
+version: 1.23
Modified: branches/upstream/liborlite-perl/current/lib/ORLite.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/lib/ORLite.pm?rev=38683&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/lib/ORLite.pm (original)
+++ branches/upstream/liborlite-perl/current/lib/ORLite.pm Fri Jun 26 12:44:09 2009
@@ -15,7 +15,7 @@
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.22';
+ $VERSION = '1.23';
}
@@ -235,8 +235,7 @@
$table->{cindex} = map { $_->{name} => $_ } @columns;
# Discover the primary key
- $table->{pk} = List::Util::first { $_->{pk} } @columns;
- $table->{pk} = $table->{pk}->{name} if $table->{pk};
+ @{$table->{pk}} = map($_->{name}, grep { $_->{pk} } @columns);
# What will be the class for this table
$table->{class} = ucfirst lc $table->{name};
@@ -306,6 +305,11 @@
if ( defined $table->{pk} and ! $readonly ) {
my $nattr = join "\n", map { "\t\t$_ => \$attr{$_}," } @names;
my $iattr = join "\n", map { "\t\t\$self->{$_}," } @names;
+ my $fill_pk = scalar @{$table->{pk}} == 1
+ ? "\t\$self->{$table->{pk}->[0]} = \$dbh->func('last_insert_rowid') unless \$self->{$table->{pk}->[0]};"
+ : q{};
+ my $where_pk = join(' and ', map("$_ = ?", @{$table->{pk}}));
+ my $where_pk_attr = join("\n", map("\t\t\$self->{$_},", @{$table->{pk}}));
$code .= <<"END_PERL";
sub new {
@@ -326,15 +330,16 @@
\$dbh->do('$sql->{insert}', {},
$iattr
);
- \$self->{$table->{pk}} = \$dbh->func('last_insert_rowid') unless \$self->{$table->{pk}};
+$fill_pk
return \$self;
}
sub delete {
my \$self = shift;
return $pkg->do(
- 'delete from $table->{name} where $table->{pk} = ?',
- {}, \$self->{$table->{pk}},
+ 'delete from $table->{name} where $where_pk',
+ {},
+$where_pk_attr
) if ref \$self;
Carp::croak("Must use truncate to delete all rows") unless \@_;
return $pkg->do(
@@ -354,7 +359,7 @@
# Generate the accessors
$code .= join "\n\n", map { $_->{fk} ? <<"END_DIRECT" : <<"END_ACCESSOR" } @columns;
sub $_->{name} {
- ($_->{fk}->[1]->{class}\->select('where $_->{fk}->[1]->{pk} = ?', \$_[0]->{$_->{name}}))[0];
+ ($_->{fk}->[1]->{class}\->select('where $_->{fk}->[1]->{pk}->[0] = ?', \$_[0]->{$_->{name}}))[0];
}
END_DIRECT
sub $_->{name} {
Modified: branches/upstream/liborlite-perl/current/t/06_create.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/06_create.t?rev=38683&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/06_create.t (original)
+++ branches/upstream/liborlite-perl/current/t/06_create.t Fri Jun 26 12:44:09 2009
@@ -34,7 +34,7 @@
create => 1,
tables => 0,
append => 'sub append { 2 }',
-}, -DEBUG;
+};
1;
END_PERL
Added: branches/upstream/liborlite-perl/current/t/07_pk.sql
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/07_pk.sql?rev=38683&op=file
==============================================================================
--- branches/upstream/liborlite-perl/current/t/07_pk.sql (added)
+++ branches/upstream/liborlite-perl/current/t/07_pk.sql Fri Jun 26 12:44:09 2009
@@ -1,0 +1,17 @@
+create table table_one (
+ col1 integer not null,
+ col2 integer not null,
+ col3 string,
+ primary key ('col1', 'col2')
+);
+
+insert into table_one ( col1, col2, col3 ) values ( 1, 1, 'a' );
+insert into table_one ( col1, col2, col3 ) values ( 1, 2, 'b' );
+insert into table_one ( col1, col2, col3 ) values ( 1, 3, 'c' );
+insert into table_one ( col1, col2, col3 ) values ( 2, 1, 'd' );
+insert into table_one ( col1, col2, col3 ) values ( 2, 2, 'e' );
+insert into table_one ( col1, col2, col3 ) values ( 2, 3, 'f' );
+insert into table_one ( col1, col2, col3 ) values ( 3, 1, 'g' );
+insert into table_one ( col1, col2, col3 ) values ( 3, 2, 'h' );
+insert into table_one ( col1, col2, col3 ) values ( 3, 3, 'i' );
+
Added: branches/upstream/liborlite-perl/current/t/07_pk.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/07_pk.t?rev=38683&op=file
==============================================================================
--- branches/upstream/liborlite-perl/current/t/07_pk.t (added)
+++ branches/upstream/liborlite-perl/current/t/07_pk.t Fri Jun 26 12:44:09 2009
@@ -1,0 +1,48 @@
+#!/usr/bin/perl
+
+# Tests relating to primary keys.
+
+BEGIN {
+ $| = 1;
+ $^W = 1;
+}
+
+use Test::More tests => 6;
+use File::Spec::Functions ':ALL';
+use t::lib::Test;
+
+
+#####################################################################
+# Set up for testing
+
+# Connect
+my $file = test_db();
+my $dbh = create_ok(
+ file => catfile(qw{ t 07_pk.sql }),
+ connect => [ "dbi:SQLite:$file" ],
+);
+
+# Create the test package
+eval <<"END_PERL"; die $@ if $@;
+package Foo::Bar;
+
+use strict;
+use ORLite '$file';
+
+1;
+END_PERL
+
+
+#####################################################################
+# Run the tests
+
+my @t1 = Foo::Bar::TableOne->select;
+is( scalar(@t1), 9, 'Got 9 table_one objects' );
+isa_ok( $t1[0], 'Foo::Bar::TableOne' );
+is( $t1[2]->delete(), 1, 'One entry deleted');
+ at t1 = Foo::Bar::TableOne->select('where col1 = ?', 1);
+is( scalar(@t1), 2, 'Got 2 table_one objects' );
+ at t1 = Foo::Bar::TableOne->select('where col1 = ? and col2 = ?', 1, 2);
+is( $t1[0]->col3, 'b', 'Got line with col3 = b');
+
+1;
Modified: branches/upstream/liborlite-perl/current/t/lib/Test.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/lib/Test.pm?rev=38683&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/lib/Test.pm (original)
+++ branches/upstream/liborlite-perl/current/t/lib/Test.pm Fri Jun 26 12:44:09 2009
@@ -8,7 +8,7 @@
use vars qw{$VERSION @ISA @EXPORT};
BEGIN {
- $VERSION = '1.22';
+ $VERSION = '1.23';
@ISA = 'Exporter';
@EXPORT = qw{ test_db connect_ok create_ok };
}
More information about the Pkg-perl-cvs-commits
mailing list