r65416 - in /branches/upstream/liborlite-perl/current: Changes MANIFEST META.yml README lib/ORLite.pm t/08_prune.pl t/17_cache.t t/18_update.sql t/18_update.t t/lib/Test.pm
angelabad-guest at users.alioth.debian.org
angelabad-guest at users.alioth.debian.org
Tue Nov 30 17:02:14 UTC 2010
Author: angelabad-guest
Date: Tue Nov 30 16:59:54 2010
New Revision: 65416
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=65416
Log:
[svn-upgrade] new version liborlite-perl (1.46)
Added:
branches/upstream/liborlite-perl/current/t/18_update.sql
branches/upstream/liborlite-perl/current/t/18_update.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/README
branches/upstream/liborlite-perl/current/lib/ORLite.pm
branches/upstream/liborlite-perl/current/t/08_prune.pl
branches/upstream/liborlite-perl/current/t/17_cache.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=65416&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/Changes (original)
+++ branches/upstream/liborlite-perl/current/Changes Tue Nov 30 16:59:54 2010
@@ -1,4 +1,11 @@
Changes for Perl extension ORLite
+
+1.46 Tue 30 Nov 2010
+ - Bumped File::Path dependency to 2.08 to prevent test failures
+ from the one shipped with Perl 5.8.9 (AZAWAWI)
+ - Added experimental base class ->update support (ADAMK)
+ - Added the qname attributes to the generator structs to simplify
+ and improve readability of SQL fragment strings (ADAMK)
1.45 Sun 8 Aug 2010
- Adding initial support for cache => $directory (ADAMK)
Modified: branches/upstream/liborlite-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/MANIFEST?rev=65416&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/MANIFEST (original)
+++ branches/upstream/liborlite-perl/current/MANIFEST Tue Nov 30 16:59:54 2010
@@ -38,6 +38,8 @@
t/16_array_create.t
t/17_cache.sql
t/17_cache.t
+t/18_update.sql
+t/18_update.t
t/lib/Test.pm
xt/meta.t
xt/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=65416&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/META.yml (original)
+++ branches/upstream/liborlite-perl/current/META.yml Tue Nov 30 16:59:54 2010
@@ -25,7 +25,7 @@
DBD::SQLite: 1.27
DBI: 1.607
File::Basename: 0
- File::Path: 2.04
+ File::Path: 2.08
File::Remove: 1.40
File::Spec: 0.80
File::Temp: 0.20
@@ -35,4 +35,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.45
+version: 1.46
Modified: branches/upstream/liborlite-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/README?rev=65416&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/README (original)
+++ branches/upstream/liborlite-perl/current/README Tue Nov 30 16:59:54 2010
@@ -32,7 +32,7 @@
tables => [ 'table1', 'table2' ],
cleanup => 'VACUUM',
prune => 1,
- );
+ };
DESCRIPTION
SQLite is a light single file SQL database that provides an excellent
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=65416&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/lib/ORLite.pm (original)
+++ branches/upstream/liborlite-perl/current/lib/ORLite.pm Tue Nov 30 16:59:54 2010
@@ -6,7 +6,7 @@
use strict;
use Carp ();
use File::Spec 0.80 ();
-use File::Path 2.04 ();
+use File::Path 2.08 ();
use File::Basename 0 ();
use Params::Util 0.33 ();
use DBI 1.607 ();
@@ -14,7 +14,7 @@
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.45';
+ $VERSION = '1.46';
}
# Support for the 'prune' option
@@ -81,6 +81,9 @@
}
unless ( defined $params{tables} ) {
$params{tables} = 1;
+ }
+ unless ( defined $params{x_update} ) {
+ $params{x_update} = 0;
}
unless ( defined $params{package} ) {
$params{package} = scalar caller;
@@ -301,6 +304,29 @@
END_PERL
+ # Experimental update support
+ if ( $params{x_update} ) {
+ $code .= <<"END_PERL";
+
+### EXPERIMENTAL
+sub update {
+ my \$class = shift;
+ my \$table = shift;
+ my \$set = shift;
+ my \@cols = sort keys %\$set;
+ my \$sql = 'update "' . \$table . '" set '
+ . join ', ', map { "\\"\$_\\" = ?" } \@cols;
+ \$sql .= ' ' . shift if \@_;
+ return $pkg->do(
+ \$sql, {},
+ ( map { \$set->{\$_} } \@cols ),
+ \@_,
+ );
+}
+
+END_PERL
+ }
+
# Cleanup and shutdown operations
if ( $cleanup ) {
$code .= <<"END_PERL";
@@ -336,6 +362,9 @@
# Capture the raw schema column information
foreach my $table ( @$tables ) {
+ # Convenience pre-quoted form of the table name
+ $table->{qname} = '"' . $table->{name} . '"';
+
# What will be the class for this table
$table->{class} = ucfirst lc $table->{name};
$table->{class} =~ s/_([a-z])/uc($1)/ge;
@@ -347,11 +376,14 @@
{ Slice => {} },
);
+ # Convenience escaping for the column names
+ $_->{qname} = "\"$_->{name}\"" foreach @$columns;
+
# Generate the object keys for the columns
if ( $array ) {
foreach my $i ( 0 .. $#$columns ) {
- $columns->[$i]->{xs} = $i;
- $columns->[$i]->{key} = "[$i]";
+ $columns->[$i]->{xs} = $i;
+ $columns->[$i]->{key} = "[$i]";
}
} else {
foreach my $c ( @$columns ) {
@@ -366,16 +398,16 @@
$table->{create} = !! ( $table->{pks} and ! $readonly );
# Generate the main SQL fragments
- $table->{sql_cols} = join ', ', map { '"' . $_->{name} . '"' } @$columns;
- $table->{sql_vals} = join ', ', ('?') x scalar @$columns;
- $table->{sql_select} = "select $table->{sql_cols} from \"$table->{name}\"";
- $table->{sql_count} = "select count(*) from \"$table->{name}\"";
+ $table->{sql_cols} = join ', ', map { $_->{qname} } @$columns;
+ $table->{sql_vals} = join ', ', ( '?' ) x scalar @$columns;
+ $table->{sql_select} = "select $table->{sql_cols} from $table->{qname}";
+ $table->{sql_count} = "select count(*) from $table->{qname}";
$table->{sql_insert} =
- "insert into \"$table->{name}\" " .
+ "insert into $table->{qname} " .
"( $table->{sql_cols} ) " .
"values ( $table->{sql_vals} )";
$table->{sql_where} = join ' and ',
- map { "\"$_->{name}\" = ?" } @{$table->{pk}};
+ map { "$_->{qname} = ?" } @{$table->{pk}};
# Generate the new Perl fragments
$table->{pl_new} = join "\n", map {
@@ -560,27 +592,28 @@
sub delete {
my \$self = shift;
return $pkg->do(
- 'delete from \"$table->{name}\" where $table->{sql_where}',
+ 'delete from $table->{qname} where $table->{sql_where}',
{},
$table->{pl_where}
) if ref \$self;
Carp::croak("Must use truncate to delete all rows") unless \@_;
return $pkg->do(
- 'delete from \"$table->{name}\" ' . shift,
+ 'delete from $table->{qname} ' . shift,
{}, \@_,
);
}
sub truncate {
- $pkg->do('delete from \"$table->{name}\"');
+ $pkg->do('delete from $table->{qname}');
}
END_PERL
-
- if ( $table->{create} and $array ) {
- # Add an additional set method to avoid having
- # the user have to enter manual positions.
- $code .= <<"END_PERL";
+ }
+
+ if ( $table->{create} and $array ) {
+ # Add an additional set method to avoid having
+ # the user have to enter manual positions.
+ $code .= <<"END_PERL";
sub set {
my \$self = shift;
my \$i = {
@@ -591,13 +624,12 @@
}
END_PERL
- }
}
- # Generate the boring accessors
- if ( $xsaccessor ) {
- my $type = $table->{create} ? 'accessors' : 'getters';
- $code .= <<"END_PERL";
+ # Generate the boring accessors
+ if ( $xsaccessor ) {
+ my $type = $table->{create} ? 'accessors' : 'getters';
+ $code .= <<"END_PERL";
use $xsclass 1.05 {
getters => {
$table->{pl_accessor}
@@ -605,20 +637,50 @@
};
END_PERL
- } else {
- $code .= join "\n\n", map { <<"END_PERL" } grep { ! $_->{fk} } @columns;
+ } else {
+ $code .= join "\n\n", map { <<"END_PERL" } grep { ! $_->{fk} } @columns;
sub $_->{name} {
\$_[0]->$_->{key};
}
END_PERL
- }
-
- # Generate the foreign key accessors
- $code .= join "\n\n", map { <<"END_PERL" } grep { $_->{fk} } @columns;
+ }
+
+ # Generate the foreign key accessors
+ $code .= join "\n\n", map { <<"END_PERL" } grep { $_->{fk} } @columns;
sub $_->{name} {
($_->{fk}->[1]->{class}\->select('where \"$_->{fk}->[1]->{pk}->[0]->{name}\" = ?', \$_[0]->$_->{key}))[0];
}
END_PERL
+
+ # Add the experimental update method
+ if ( $table->{create} and $params{x_update} ) {
+ my @pk = map { $_->{name} } @{$table->{pk}};
+ my $wsql = join ' and ', map { "\"$_\" = ?" } @pk;
+ my $wattr = join ', ', map { "\$self->$_" } @pk;
+ my $set = $array
+ ? '$self->set( $_ => $set{$_} ) foreach keys %set;'
+ : '$self->{$_} = $set{$_} foreach keys %set;';
+ $code .= <<"END_PERL";
+
+### EXPERIMENTAL
+sub update {
+ my \$self = shift;
+ my \%set = \@_;
+ my \$rows = $pkg->do(
+ 'update $table->{qname} set ' .
+ join( ', ', map { "\\"\$_\\" = ?" } keys \%set ) .
+ ' where $wsql',
+ {}, values \%set, $wattr,
+ );
+ unless ( \$rows == 1 ) {
+ die "Expected to update 1 row, actually updated \$rows";
+ }
+ $set
+ return 1;
+}
+END_PERL
+ }
+
}
}
$dbh->disconnect;
@@ -648,12 +710,12 @@
local $@;
if ( $^P and $^V >= 5.008009 ) {
local $^P = $^P | 0x800;
- eval $code;
+ eval($code);
die $@ if $@;
} elsif ( $DEBUG ) {
dval($code);
} else {
- eval $code;
+ eval($code);
die $@ if $@;
}
@@ -730,7 +792,7 @@
tables => [ 'table1', 'table2' ],
cleanup => 'VACUUM',
prune => 1,
- );
+ };
=head1 DESCRIPTION
Modified: branches/upstream/liborlite-perl/current/t/08_prune.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/08_prune.pl?rev=65416&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/08_prune.pl (original)
+++ branches/upstream/liborlite-perl/current/t/08_prune.pl Tue Nov 30 16:59:54 2010
@@ -4,7 +4,7 @@
use strict;
-our $VERSION = '1.45';
+our $VERSION = '1.46';
unless ( $ORLite::VERSION eq $VERSION ) {
die('Failed to load correct ORLite version');
Modified: branches/upstream/liborlite-perl/current/t/17_cache.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/17_cache.t?rev=65416&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/17_cache.t (original)
+++ branches/upstream/liborlite-perl/current/t/17_cache.t Tue Nov 30 16:59:54 2010
@@ -14,7 +14,7 @@
use t::lib::Test;
# Where will the cache file be written to
-my $cached = catfile( qw{ t Foo-Bar-1-23-ORLite-1-45-user_version-2.pm } );
+my $cached = catfile( qw{ t Foo-Bar-1-23-ORLite-1-46-user_version-2.pm } );
clear($cached);
ok( ! -e $cached, 'Cache file does not initially exist' );
Added: branches/upstream/liborlite-perl/current/t/18_update.sql
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/18_update.sql?rev=65416&op=file
==============================================================================
--- branches/upstream/liborlite-perl/current/t/18_update.sql (added)
+++ branches/upstream/liborlite-perl/current/t/18_update.sql Tue Nov 30 16:59:54 2010
@@ -1,0 +1,4 @@
+create table table_one (
+ col1 integer not null primary key,
+ col2 string
+)
Added: branches/upstream/liborlite-perl/current/t/18_update.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/18_update.t?rev=65416&op=file
==============================================================================
--- branches/upstream/liborlite-perl/current/t/18_update.t (added)
+++ branches/upstream/liborlite-perl/current/t/18_update.t Tue Nov 30 16:59:54 2010
@@ -1,0 +1,144 @@
+#!/usr/bin/perl
+
+# Tests for the experimental update methods
+
+BEGIN {
+ $| = 1;
+ $^W = 1;
+}
+
+use Test::More tests => 18;
+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 18_update.sql }),
+ connect => [ "dbi:SQLite:$file" ],
+);
+
+# Create the test package
+eval <<"END_PERL"; die $@ if $@;
+package Foo::Bar;
+
+use strict;
+use ORLite {
+ file => '$file',
+ x_update => 1,
+};
+
+1;
+END_PERL
+
+
+
+
+
+#####################################################################
+# Tests for the base package update methods
+
+isa_ok(
+ Foo::Bar::TableOne->create(
+ col1 => 1,
+ col2 => 'foo',
+ ),
+ 'Foo::Bar::TableOne',
+);
+isa_ok(
+ Foo::Bar::TableOne->create(
+ col1 => 2,
+ col2 => 'bar',
+ ),
+ 'Foo::Bar::TableOne',
+);
+is( Foo::Bar::TableOne->count, 2, 'Found 2 rows' );
+is(
+ Foo::Bar->update(
+ Foo::Bar::TableOne->table,
+ {
+ col2 => 'baz',
+ },
+ ),
+ 2,
+ 'Updated 2 rows',
+);
+is(
+ Foo::Bar::TableOne->count('where col2 = ?', 'baz'),
+ 2,
+ 'Updated 2 rows',
+);
+is(
+ Foo::Bar->update(
+ Foo::Bar::TableOne->table,
+ {
+ col2 => 'one',
+ },
+ 'where col1 = ?', 1,
+ ),
+ 1,
+ 'Updated 1 rows',
+);
+is(
+ Foo::Bar::TableOne->count('where col2 = ?', 'one'),
+ 1,
+ 'Updated 1 row',
+);
+is(
+ Foo::Bar->update(
+ Foo::Bar::TableOne->table,
+ {
+ col2 => 'three',
+ },
+ 'where col1 = ?', 3,
+ ),
+ '0E0',
+ 'Updated 0 rows',
+);
+is(
+ Foo::Bar::TableOne->count('where col2 = ?', 'three'),
+ 0,
+ 'Updated 0 rows',
+);
+
+
+
+
+
+######################################################################
+# Test for the table update method
+
+# Check the object as is
+my $one = Foo::Bar::TableOne->load(1);
+isa_ok( $one, 'Foo::Bar::TableOne' );
+is( $one->col1, 1, '->col1 ok' );
+is( $one->col2, 'one', '->col2 ok' );
+
+# Update one accessor row
+is( $one->update( col2 => 'two' ), 1, '->update(accessor) ok' );
+is_deeply(
+ $one,
+ Foo::Bar::TableOne->load(1),
+ 'Change is applied identically to object and database forms',
+);
+
+# Change a primary key as well
+is( $one->update( col1 => 3, col2 => 'three' ), 1, '->update(pk) ok' );
+is_deeply(
+ $one,
+ Foo::Bar::TableOne->load(3),
+ 'Change is applied identically to object and database forms',
+);
+
+# Do we throw an exception on now columns
+eval {
+ $one->update();
+};
+ok( $@, 'Exception thrown on null update' );
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=65416&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/lib/Test.pm (original)
+++ branches/upstream/liborlite-perl/current/t/lib/Test.pm Tue Nov 30 16:59:54 2010
@@ -9,7 +9,7 @@
use vars qw{$VERSION @ISA @EXPORT};
BEGIN {
- $VERSION = '1.45';
+ $VERSION = '1.46';
@ISA = 'Exporter';
@EXPORT = qw{ test_db connect_ok create_ok };
}
More information about the Pkg-perl-cvs-commits
mailing list