r65727 - in /branches/upstream/liborlite-perl/current: Changes MANIFEST META.yml lib/ORLite.pm t/08_prune.pl t/17_cache.t t/19_view.sql t/19_view.t t/lib/Test.pm
angelabad-guest at users.alioth.debian.org
angelabad-guest at users.alioth.debian.org
Sat Dec 11 12:07:55 UTC 2010
Author: angelabad-guest
Date: Sat Dec 11 12:07:29 2010
New Revision: 65727
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=65727
Log:
[svn-upgrade] new version liborlite-perl (1.47)
Added:
branches/upstream/liborlite-perl/current/t/19_view.sql
branches/upstream/liborlite-perl/current/t/19_view.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/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=65727&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/Changes (original)
+++ branches/upstream/liborlite-perl/current/Changes Sat Dec 11 12:07:29 2010
@@ -1,4 +1,7 @@
Changes for Perl extension ORLite
+
+1.47 Wed 8 Dec 2010
+ - Adding readonly support for views (ADAMK)
1.46 Tue 30 Nov 2010
- Bumped File::Path dependency to 2.08 to prevent test failures
Modified: branches/upstream/liborlite-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/MANIFEST?rev=65727&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/MANIFEST (original)
+++ branches/upstream/liborlite-perl/current/MANIFEST Sat Dec 11 12:07:29 2010
@@ -40,6 +40,8 @@
t/17_cache.t
t/18_update.sql
t/18_update.t
+t/19_view.sql
+t/19_view.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=65727&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/META.yml (original)
+++ branches/upstream/liborlite-perl/current/META.yml Sat Dec 11 12:07:29 2010
@@ -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.46
+version: 1.47
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=65727&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/lib/ORLite.pm (original)
+++ branches/upstream/liborlite-perl/current/lib/ORLite.pm Sat Dec 11 12:07:29 2010
@@ -14,7 +14,7 @@
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.46';
+ $VERSION = '1.47';
}
# Support for the 'prune' option
@@ -81,6 +81,9 @@
}
unless ( defined $params{tables} ) {
$params{tables} = 1;
+ }
+ unless ( defined $params{views} ) {
+ $params{views} = 0;
}
unless ( defined $params{x_update} ) {
$params{x_update} = 0;
@@ -169,11 +172,6 @@
my $cleanup = $params{cleanup};
my $xsaccessor = $params{xsaccessor};
my $array = $params{array};
- my $xsclass = $array ? 'Class::XSAccessor::Array' : 'Class::XSAccessor';
- my $l = $array ? '[' : '{';
- my $r = $array ? ']' : '}';
- my $slice = $array ? '{}' : '{ Slice => {} }';
- my $rowref = $array ? 'arrayref' : 'hashref';
# Generate the support package code
my $code = <<"END_PERL";
@@ -355,8 +353,8 @@
if ( $params{tables} ) {
# Capture the raw schema table information
my $tables = $dbh->selectall_arrayref(
- 'select * from sqlite_master where name not like ? and type = ?',
- { Slice => {} }, 'sqlite_%', 'table',
+ 'select * from sqlite_master where name not like ? and type in ( ?, ? )',
+ { Slice => {} }, 'sqlite_%', 'table', 'view',
);
my %tindex = map { $_->{name} => $_ } @$tables;
@@ -379,8 +377,17 @@
# Convenience escaping for the column names
$_->{qname} = "\"$_->{name}\"" foreach @$columns;
+ # Track array vs hash implementation on a per-table
+ # basis so that we can force views to always be done
+ # array-wise (to compensate for some weird SQLite
+ # column quoting differences between tables and views
+ $table->{array} = $array;
+ if ( $table->{type} eq 'view' ) {
+ $table->{array} = 1;
+ }
+
# Generate the object keys for the columns
- if ( $array ) {
+ if ( $table->{array} ) {
foreach my $i ( 0 .. $#$columns ) {
$columns->[$i]->{xs} = $i;
$columns->[$i]->{key} = "[$i]";
@@ -411,8 +418,9 @@
# Generate the new Perl fragments
$table->{pl_new} = join "\n", map {
- $array ? "\t\t\$attr{$_->{name}},"
- : "\t\t$_->{name} => \$attr{$_->{name}},"
+ $table->{array}
+ ? "\t\t\$attr{$_->{name}},"
+ : "\t\t$_->{name} => \$attr{$_->{name}},"
} @$columns;
$table->{pl_insert} = join "\n", map {
@@ -458,6 +466,9 @@
# Generate the per-table code
foreach my $table ( @$tables ) {
my @columns = @{$table->{columns}};
+ my $slice = $table->{array}
+ ? '{}'
+ : '{ Slice => {} }';
# Generate the elements in all packages
$code .= <<"END_PERL";
@@ -493,7 +504,7 @@
END_PERL
# Handle different versions, because arrayref acts funny
- if ( $array ) {
+ if ( $table->{array} ) {
$code .= <<"END_PERL";
sub iterate {
my \$class = shift;
@@ -531,7 +542,7 @@
# Add the primary key based single object loader
if ( $table->{pks} ) {
- if ( $array ) {
+ if ( $table->{array} ) {
$code .= <<"END_PERL";
sub load {
my \$class = shift;
@@ -566,6 +577,8 @@
# Generate the elements for tables with primary keys
if ( $table->{create} ) {
+ my $l = $table->{array} ? '[' : '{';
+ my $r = $table->{array} ? ']' : '}';
$code .= <<"END_PERL";
sub new {
my \$class = shift;
@@ -610,7 +623,7 @@
END_PERL
}
- if ( $table->{create} and $array ) {
+ if ( $table->{create} and $table->{array} ) {
# Add an additional set method to avoid having
# the user have to enter manual positions.
$code .= <<"END_PERL";
@@ -628,7 +641,11 @@
# Generate the boring accessors
if ( $xsaccessor ) {
- my $type = $table->{create} ? 'accessors' : 'getters';
+ my $type = $table->{create} ? 'accessors' : 'getters';
+ my $xsclass = $table->{array}
+ ? 'Class::XSAccessor::Array'
+ : 'Class::XSAccessor';
+
$code .= <<"END_PERL";
use $xsclass 1.05 {
getters => {
@@ -657,7 +674,7 @@
my @pk = map { $_->{name} } @{$table->{pk}};
my $wsql = join ' and ', map { "\"$_\" = ?" } @pk;
my $wattr = join ', ', map { "\$self->$_" } @pk;
- my $set = $array
+ my $set = $table->{array}
? '$self->set( $_ => $set{$_} ) foreach keys %set;'
: '$self->{$_} = $set{$_} foreach keys %set;';
$code .= <<"END_PERL";
@@ -680,9 +697,22 @@
}
END_PERL
}
-
}
}
+
+ # Optionally generate the table classes
+ if ( $params{views} ) {
+ # Capture the raw schema table information
+ my $views = $dbh->selectall_arrayref(
+ 'select * from sqlite_master where name not like ? and type = ?',
+ { Slice => {} }, 'sqlite_%', 'view',
+ );
+ my %vindex = map { $_->{name} => $_ } @$views;
+
+ 1;
+ }
+
+ # We are finished with it now
$dbh->disconnect;
# Add any custom code to the end
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=65727&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/08_prune.pl (original)
+++ branches/upstream/liborlite-perl/current/t/08_prune.pl Sat Dec 11 12:07:29 2010
@@ -4,7 +4,7 @@
use strict;
-our $VERSION = '1.46';
+our $VERSION = '1.47';
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=65727&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/17_cache.t (original)
+++ branches/upstream/liborlite-perl/current/t/17_cache.t Sat Dec 11 12:07:29 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-46-user_version-2.pm } );
+my $cached = catfile( qw{ t Foo-Bar-1-23-ORLite-1-47-user_version-2.pm } );
clear($cached);
ok( ! -e $cached, 'Cache file does not initially exist' );
Added: branches/upstream/liborlite-perl/current/t/19_view.sql
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/19_view.sql?rev=65727&op=file
==============================================================================
--- branches/upstream/liborlite-perl/current/t/19_view.sql (added)
+++ branches/upstream/liborlite-perl/current/t/19_view.sql Sat Dec 11 12:07:29 2010
@@ -1,0 +1,7 @@
+create table table_one (
+ col1 integer not null primary key,
+ col2 string
+);
+
+create view view_one as
+select * from table_one;
Added: branches/upstream/liborlite-perl/current/t/19_view.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/19_view.t?rev=65727&op=file
==============================================================================
--- branches/upstream/liborlite-perl/current/t/19_view.t (added)
+++ branches/upstream/liborlite-perl/current/t/19_view.t Sat Dec 11 12:07:29 2010
@@ -1,0 +1,199 @@
+#!/usr/bin/perl
+
+# Tests the basic functionality of SQLite.
+
+use strict;
+
+BEGIN {
+ $| = 1;
+ $^W = 1;
+}
+
+use Test::More tests => 81;
+use File::Spec::Functions ':ALL';
+use t::lib::Test;
+
+# Set up again
+my $file = test_db();
+my $dbh = create_ok(
+ file => catfile(qw{ t 19_view.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
+
+# Simple null transaction to stimulate any errors
+Foo::Bar->begin;
+Foo::Bar->rollback;
+
+# Check the file name
+$file = rel2abs($file);
+is( Foo::Bar->sqlite, $file, '->sqlite ok' );
+is( Foo::Bar->dsn, "dbi:SQLite:$file", '->dsn ok' );
+
+# Check the schema version
+is( Foo::Bar->pragma('user_version'), 0, '->user_version ok' );
+
+# Check metadata methods in the test table
+is( Foo::Bar::ViewOne->base, 'Foo::Bar', '->base ok' );
+is( Foo::Bar::ViewOne->table, 'view_one', '->table ok' );
+my $columns = Foo::Bar::ViewOne->table_info;
+is_deeply( $columns, [
+ {
+ cid => 0,
+ dflt_value => undef,
+ name => 'col1',
+ notnull => 0,
+ pk => 0,
+ type => 'integer',
+ },
+ {
+ cid => 1,
+ dflt_value => undef,
+ name => 'col2',
+ notnull => 0,
+ pk => 0,
+ type => 'string',
+ },
+], '->table_info ok' );
+is( Foo::Bar::TableOne->count, 0, '->count(table) is zero' );
+is( Foo::Bar::ViewOne->count, 0, '->count(view) is zero' );
+
+# Populate the test table
+ok(
+ Foo::Bar::TableOne->create( col1 => 1, col2 => 'foo' ),
+ 'Created row 1',
+);
+is( Foo::Bar::TableOne->count, 1, '->count(table) is one' );
+is( Foo::Bar::ViewOne->count, 1, '->count(view) is one' );
+isa_ok( Foo::Bar::TableOne->load(1), 'Foo::Bar::TableOne' );
+my $new = Foo::Bar::TableOne->create( col2 => 'bar' );
+isa_ok( $new, 'Foo::Bar::TableOne' );
+is( $new->col1, 2, '->col1 ok' );
+is( $new->col2, 'bar', '->col2 ok' );
+ok(
+ Foo::Bar::TableOne->create( col2 => 'bar' ),
+ 'Created row 3',
+);
+
+# Check the ->count method
+is( Foo::Bar::TableOne->count, 3, 'Found 3 table rows' );
+is( Foo::Bar::ViewOne->count, 3, 'Found 3 view rows' );
+is( Foo::Bar::TableOne->count('where col2 = ?', 'bar'), 2, 'Table condition count works' );
+is( Foo::Bar::ViewOne->count('where col2 = ?', 'bar'), 2, 'View condition count works' );
+
+sub test_ones {
+ my $ones = shift;
+ is( scalar(@$ones), 3, 'Got 3 objects' );
+ isa_ok( $ones->[0], 'Foo::Bar::ViewOne' );
+ is( $ones->[0]->col1, 1, '->col1 ok' );
+ is( $ones->[0]->col2, 'foo', '->col2 ok' );
+ isa_ok( $ones->[1], 'Foo::Bar::ViewOne' );
+ is( $ones->[1]->col1, 2, '->col1 ok' );
+ is( $ones->[1]->col2, 'bar', '->col2 ok' );
+ isa_ok( $ones->[2], 'Foo::Bar::ViewOne' );
+ is( $ones->[2]->col1, 3, '->col1 ok' );
+ is( $ones->[2]->col2, 'bar', '->col2 ok' );
+}
+
+# Fetch the rows (list context)
+test_ones(
+ [ Foo::Bar::ViewOne->select('order by col1') ]
+);
+
+# Fetch the rows (scalar context)
+test_ones(
+ scalar Foo::Bar::ViewOne->select('order by col1')
+);
+
+SCOPE: {
+ # Emulate select via iterate
+ my $ones = [];
+ Foo::Bar::ViewOne->iterate( 'order by col1', sub {
+ push @$ones, $_;
+ } );
+ test_ones( $ones );
+
+ # Partial fetch
+ my $short = [];
+ Foo::Bar::ViewOne->iterate( 'order by col1', sub {
+ push @$short, $_;
+ return 0;
+ } );
+ is( scalar(@$short), 1, 'Found only one record' );
+ is_deeply( $short->[0], $ones->[0], 'Found the same first record' );
+
+ # Lower level equivalent
+ my $short2 = [];
+ Foo::Bar->iterate( 'select * from view_one order by col1', sub {
+ push @$short2, $_;
+ return 0;
+ } );
+ is( scalar(@$short2), 1, 'Found only one record' );
+ is_deeply( $short2->[0], [ 1, 'foo' ], 'Found correct alternative' );
+
+ # Delete one of the objects via the class delete method
+ my $rv1 = Foo::Bar::TableOne->delete('where col2 = ?', 'bar');
+ is( $rv1, 2, 'Deleted 2 rows' );
+ is( Foo::Bar::ViewOne->count, 1, 'Confirm 2 rows were deleted' );
+
+ # Truncate so we can continue
+ ok( Foo::Bar::TableOne->truncate, '->truncate ok' );
+ is( Foo::Bar::ViewOne->count, 0, 'Confirm table/view are empty' );
+}
+
+# Database should now be empty
+SCOPE: {
+ my @none = Foo::Bar::ViewOne->select;
+ is_deeply( \@none, [ ], '->select ok with nothing' );
+
+ my $none = Foo::Bar::ViewOne->select;
+ is_deeply( $none, [ ], '->select ok with nothing' );
+}
+
+# Transaction testing
+SCOPE: {
+ is( Foo::Bar->connected, !1, '->connected is false' );
+ ok( Foo::Bar->begin, '->begin' );
+ is( Foo::Bar->connected, 1, '->connected is true' );
+ isa_ok( Foo::Bar::TableOne->create, 'Foo::Bar::TableOne' );
+ is( Foo::Bar::ViewOne->count, 1, 'One row created' );
+ ok( Foo::Bar->rollback, '->rollback' );
+ is( Foo::Bar->connected, !1, '->connected is false' );
+ is( Foo::Bar::ViewOne->count, 0, 'Commit ok' );
+
+ ok( Foo::Bar->begin, '->begin' );
+ isa_ok( Foo::Bar::TableOne->create, 'Foo::Bar::TableOne' );
+ is( Foo::Bar::ViewOne->count, 1, 'One row created' );
+ ok( Foo::Bar->commit, '->commit' );
+ is( Foo::Bar::ViewOne->count, 1, 'Commit ok' );
+}
+
+# Truncate
+SCOPE: {
+ ok( Foo::Bar::TableOne->truncate, '->truncate ok' );
+ is( Foo::Bar::ViewOne->count, 0, 'Commit ok' );
+}
+
+
+
+
+
+######################################################################
+# Exceptions
+
+# Load an object that does not exist
+SCOPE: {
+ # There should not be any of the state-altering methods
+ foreach ( qw{ load insert update delete truncate } ) {
+ is( Foo::Bar::ViewOne->can($_), undef, "Method $_ does not exist" );
+ }
+}
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=65727&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/lib/Test.pm (original)
+++ branches/upstream/liborlite-perl/current/t/lib/Test.pm Sat Dec 11 12:07:29 2010
@@ -9,7 +9,7 @@
use vars qw{$VERSION @ISA @EXPORT};
BEGIN {
- $VERSION = '1.46';
+ $VERSION = '1.47';
@ISA = 'Exporter';
@EXPORT = qw{ test_db connect_ok create_ok };
}
More information about the Pkg-perl-cvs-commits
mailing list