r25397 - in /branches/upstream/liborlite-perl/current: Changes MANIFEST META.yml lib/ORLite.pm t/01_compile.t t/04_readonly.t t/05_notables.t t/lib/Test.pm
dmn at users.alioth.debian.org
dmn at users.alioth.debian.org
Fri Sep 19 20:16:13 UTC 2008
Author: dmn
Date: Fri Sep 19 20:16:10 2008
New Revision: 25397
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=25397
Log:
[svn-upgrade] Integrating new upstream version, liborlite-perl (0.13)
Added:
branches/upstream/liborlite-perl/current/t/05_notables.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/01_compile.t
branches/upstream/liborlite-perl/current/t/04_readonly.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=25397&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/Changes (original)
+++ branches/upstream/liborlite-perl/current/Changes Fri Sep 19 20:16:10 2008
@@ -1,4 +1,15 @@
Changes for Perl extension ORLite
+
+0.13 Fri 19 Sep 2008
+ - Fixed critical bug introduced in 0.10 or somewhere around there,
+ where column accessors were not defined for readonly classes.
+ (This fatally killed ORLite::Mirror)
+
+0.12 Mon 15 Sep 2008
+ - Don't store the database values in a shared hash any more
+ (Makes the classes self-contained and able to run without ORLite)
+ - Add a tables param to the import, to allow the base database
+ connectivity class to be created without the table classes.
0.11 Tue 9 Sep 2008
- If we aren't debugging we don't need to write the temp file
Modified: branches/upstream/liborlite-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/MANIFEST?rev=25397&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/MANIFEST (original)
+++ branches/upstream/liborlite-perl/current/MANIFEST Fri Sep 19 20:16:10 2008
@@ -20,6 +20,7 @@
t/03_fk.sql
t/03_fk.t
t/04_readonly.t
+t/05_notables.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=25397&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/META.yml (original)
+++ branches/upstream/liborlite-perl/current/META.yml Fri Sep 19 20:16:10 2008
@@ -25,4 +25,4 @@
perl: 5.6.0
resources:
license: http://dev.perl.org/licenses/
-version: 0.11
+version: 0.13
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=25397&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/lib/ORLite.pm (original)
+++ branches/upstream/liborlite-perl/current/lib/ORLite.pm Fri Sep 19 20:16:10 2008
@@ -20,7 +20,7 @@
use vars qw{$VERSION %DSN %DBH};
BEGIN {
- $VERSION = '0.11';
+ $VERSION = '0.13';
%DSN = ();
%DBH = ();
}
@@ -50,6 +50,7 @@
file => $_[1],
readonly => undef, # Automatic
package => undef, # Automatic
+ tables => 1,
);
} elsif ( _HASH($_[1]) ) {
%params = %{ $_[1] };
@@ -61,6 +62,9 @@
}
unless ( defined $params{readonly} ) {
$params{readonly} = ! -w $params{file};
+ }
+ unless ( defined $params{tables} ) {
+ $params{tables} = 1;
}
unless ( defined $params{package} ) {
$params{package} = scalar caller;
@@ -83,80 +87,27 @@
die "Schema user_version mismatch (got $version, wanted $params{user_version})";
}
- # Capture the raw schema information
- my $tables = $dbh->selectall_arrayref(
- 'select * from sqlite_master where type = ?',
- { Slice => {} }, 'table',
- );
- foreach my $table ( @$tables ) {
- $table->{columns} = $dbh->selectall_arrayref(
- "pragma table_info('$table->{name}')",
- { Slice => {} },
- );
- }
- $dbh->disconnect;
-
-
- # Generate the main additional table level metadata
- my %tindex = map { $_->{name} => $_ } @$tables;
- foreach my $table ( @$tables ) {
- my @columns = @{ $table->{columns} };
- my @names = map { $_->{name} } @columns;
- $table->{cindex} = map { $_->{name} => $_ } @columns;
-
- # Discover the primary key
- $table->{pk} = List::Util::first { $_->{pk} } @columns;
- $table->{pk} = $table->{pk}->{name} if $table->{pk};
-
- # What will be the class for this table
- $table->{class} = ucfirst lc $table->{name};
- $table->{class} =~ s/_([a-z])/uc($1)/ge;
- $table->{class} = "${pkg}::$table->{class}";
-
- # Generate various SQL fragments
- my $sql = $table->{sql} = { create => $table->{sql} };
- $sql->{cols} = join ', ', map { '"' . $_ . '"' } @names;
- $sql->{vals} = join ', ', ('?') x scalar @columns;
- $sql->{select} = "select $table->{sql}->{cols} from $table->{name}";
- $sql->{count} = "select count(*) from $table->{name}";
- $sql->{insert} = join ' ',
- "insert into $table->{name}" .
- "( $table->{sql}->{cols} )" .
- " values ( $table->{sql}->{vals} )";
- }
-
- # Generate the foreign key metadata
- foreach my $table ( @$tables ) {
- # Locate the foreign keys
- my %fk = ();
- my @fk_sql = $table->{sql}->{create} =~ /[(,]\s*(.+?REFERENCES.+?)\s*[,)]/g;
-
- # Extract the details
- foreach ( @fk_sql ) {
- unless ( /^(\w+).+?REFERENCES\s+(\w+)\s*\(\s*(\w+)/ ) {
- die "Invalid foreign key $_";
- }
- $fk{"$1"} = [ "$2", $tindex{"$2"}, "$3" ];
- }
- foreach ( @{ $table->{columns} } ) {
- $_->{fk} = $fk{$_->{name}};
- }
- }
-
# Generate the support package code
my $code = <<"END_PERL";
package $pkg;
use strict;
+my \$DSN = 'dbi:SQLite:$file';
+my \$DBH = undef;
+
sub dsn {
- \$ORLite::DSN{'$pkg'};
+ \$DSN;
}
sub dbh {
- \$ORLite::DBH{'$pkg'} or
- DBI->connect(\$ORLite::DSN{'$pkg'}) or
+ \$DBH or
+ \$_[0]->connect or
Carp::croak("connect: \$DBI::errstr");
+}
+
+sub connect {
+ DBI->connect(\$_[0]->dsn);
}
sub do {
@@ -200,39 +151,99 @@
# Add transaction support if not readonly
$code .= <<"END_PERL" unless $readonly;
sub begin {
- \$ORLite::DBH{'$pkg'} or
- \$ORLite::DBH{'$pkg'} = DBI->connect(\$ORLite::DSN{'$pkg'}) or
+ \$DBH or
+ \$DBH = \$_[0]->connect or
Carp::croak("connect: \$DBI::errstr");
- \$ORLite::DBH{'$pkg'}->begin_work;
+ \$DBH->begin_work;
}
sub commit {
- \$ORLite::DBH{'$pkg'} or return 1;
- \$ORLite::DBH{'$pkg'}->commit;
- \$ORLite::DBH{'$pkg'}->disconnect;
- delete \$ORLite::DBH{'$pkg'};
+ \$DBH or return 1;
+ \$DBH->commit;
+ \$DBH->disconnect;
+ undef \$DBH;
return 1;
}
sub rollback {
- \$ORLite::DBH{'$pkg'} or return 1;
- \$ORLite::DBH{'$pkg'}->rollback;
- \$ORLite::DBH{'$pkg'}->disconnect;
- delete \$ORLite::DBH{'$pkg'};
+ \$DBH or return 1;
+ \$DBH->rollback;
+ \$DBH->disconnect;
+ undef \$DBH;
return 1;
}
END_PERL
- # Generate the per-table code
- foreach my $table ( @$tables ) {
- # Generate the accessors
- my $sql = $table->{sql};
- my @columns = @{ $table->{columns} };
- my @names = map { $_->{name} } @columns;
-
- # Generate the elements in all packages
- $code .= <<"END_PERL";
+ # Optionally generate the table classes
+ if ( $params{tables} ) {
+ # Capture the raw schema information
+ my $tables = $dbh->selectall_arrayref(
+ 'select * from sqlite_master where type = ?',
+ { Slice => {} }, 'table',
+ );
+ foreach my $table ( @$tables ) {
+ $table->{columns} = $dbh->selectall_arrayref(
+ "pragma table_info('$table->{name}')",
+ { Slice => {} },
+ );
+ }
+
+ # Generate the main additional table level metadata
+ my %tindex = map { $_->{name} => $_ } @$tables;
+ foreach my $table ( @$tables ) {
+ my @columns = @{ $table->{columns} };
+ my @names = map { $_->{name} } @columns;
+ $table->{cindex} = map { $_->{name} => $_ } @columns;
+
+ # Discover the primary key
+ $table->{pk} = List::Util::first { $_->{pk} } @columns;
+ $table->{pk} = $table->{pk}->{name} if $table->{pk};
+
+ # What will be the class for this table
+ $table->{class} = ucfirst lc $table->{name};
+ $table->{class} =~ s/_([a-z])/uc($1)/ge;
+ $table->{class} = "${pkg}::$table->{class}";
+
+ # Generate various SQL fragments
+ my $sql = $table->{sql} = { create => $table->{sql} };
+ $sql->{cols} = join ', ', map { '"' . $_ . '"' } @names;
+ $sql->{vals} = join ', ', ('?') x scalar @columns;
+ $sql->{select} = "select $table->{sql}->{cols} from $table->{name}";
+ $sql->{count} = "select count(*) from $table->{name}";
+ $sql->{insert} = join ' ',
+ "insert into $table->{name}" .
+ "( $table->{sql}->{cols} )" .
+ " values ( $table->{sql}->{vals} )";
+ }
+
+ # Generate the foreign key metadata
+ foreach my $table ( @$tables ) {
+ # Locate the foreign keys
+ my %fk = ();
+ my @fk_sql = $table->{sql}->{create} =~ /[(,]\s*(.+?REFERENCES.+?)\s*[,)]/g;
+
+ # Extract the details
+ foreach ( @fk_sql ) {
+ unless ( /^(\w+).+?REFERENCES\s+(\w+)\s*\(\s*(\w+)/ ) {
+ die "Invalid foreign key $_";
+ }
+ $fk{"$1"} = [ "$2", $tindex{"$2"}, "$3" ];
+ }
+ foreach ( @{ $table->{columns} } ) {
+ $_->{fk} = $fk{$_->{name}};
+ }
+ }
+
+ # Generate the per-table code
+ foreach my $table ( @$tables ) {
+ # Generate the accessors
+ my $sql = $table->{sql};
+ my @columns = @{ $table->{columns} };
+ my @names = map { $_->{name} } @columns;
+
+ # Generate the elements in all packages
+ $code .= <<"END_PERL";
package $table->{class};
sub select {
@@ -253,11 +264,11 @@
END_PERL
- # Generate the elements for tables with primary keys
- if ( defined $table->{pk} and ! $readonly ) {
- my $nattr = join "\n", map { "\t\t$_ => \$attr{$_}," } @names;
- my $iattr = join "\n", map { "\t\t\$self->{$_}," } @names;
- $code .= <<"END_PERL";
+ # Generate the elements for tables with primary keys
+ if ( defined $table->{pk} and ! $readonly ) {
+ my $nattr = join "\n", map { "\t\t$_ => \$attr{$_}," } @names;
+ my $iattr = join "\n", map { "\t\t\$self->{$_}," } @names;
+ $code .= <<"END_PERL";
sub new {
my \$class = shift;
@@ -296,6 +307,8 @@
END_PERL
+ }
+
# Generate the accessors
$code .= join "\n\n", map { $_->{fk} ? <<"END_DIRECT" : <<"END_ACCESSOR" } @columns;
sub $_->{name} {
@@ -309,6 +322,7 @@
}
}
+ $dbh->disconnect;
# Load the code
if ( $DEBUG ) {
Modified: branches/upstream/liborlite-perl/current/t/01_compile.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/01_compile.t?rev=25397&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/01_compile.t (original)
+++ branches/upstream/liborlite-perl/current/t/01_compile.t Fri Sep 19 20:16:10 2008
@@ -5,9 +5,10 @@
$^W = 1;
}
-use Test::More tests => 3;
+use Test::More tests => 4;
ok( $] >= 5.006, 'Perl version is new enough' );
require_ok( 'ORLite' );
require_ok( 't::lib::Test' );
+is( $ORLite::VERSION, $t::lib::Test::VERSION, '$VERSION match' );
Modified: branches/upstream/liborlite-perl/current/t/04_readonly.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/04_readonly.t?rev=25397&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/04_readonly.t (original)
+++ branches/upstream/liborlite-perl/current/t/04_readonly.t Fri Sep 19 20:16:10 2008
@@ -9,7 +9,7 @@
$^W = 1;
}
-use Test::More tests => 7;
+use Test::More tests => 8;
use File::Spec::Functions ':ALL';
use t::lib::Test;
@@ -52,6 +52,9 @@
# Check the ->count method
is( Foo::Bar::TableOne->count, 0, 'Found 0 rows' );
+# Make sure we still have the columns defined
+ok( Foo::Bar::TableOne->can('col1'), 'Columns defined' );
+
# There's some things we shouldn't be able to do
ok( ! Foo::Bar->can('commit'), 'No transaction support' );
ok( ! Foo::Bar::TableOne->can('create'), 'Cant create object' );
Added: branches/upstream/liborlite-perl/current/t/05_notables.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/05_notables.t?rev=25397&op=file
==============================================================================
--- branches/upstream/liborlite-perl/current/t/05_notables.t (added)
+++ branches/upstream/liborlite-perl/current/t/05_notables.t Fri Sep 19 20:16:10 2008
@@ -1,0 +1,54 @@
+#!/usr/bin/perl
+
+# Tests both readonly functionality and version locking.
+
+use strict;
+
+BEGIN {
+ $| = 1;
+ $^W = 1;
+}
+
+use Test::More tests => 5;
+use File::Spec::Functions ':ALL';
+use t::lib::Test;
+
+SCOPE: {
+ # Test file
+ my $file = test_db();
+
+ # Connect
+ my $dbh = connect_ok("dbi:SQLite:$file");
+ $dbh->begin_work;
+ $dbh->rollback;
+ ok( $dbh->disconnect, 'disconnect' );
+}
+
+# Set up again
+my $file = test_db();
+my $dbh = create_ok(
+ file => catfile(qw{ t 02_basics.sql }),
+ connect => [ "dbi:SQLite:$file" ],
+ user_version => 10,
+);
+
+# Create the test package
+eval <<"END_PERL"; die $@ if $@;
+package Foo::Bar;
+
+use strict;
+use ORLite {
+ file => '$file',
+ readonly => 1,
+ user_version => 10,
+ tables => 0,
+};
+
+1;
+END_PERL
+
+# Check the user_version value
+is( Foo::Bar->pragma('user_version'), 10, '->user_version ok' );
+
+# Check the ->count method
+ok( ! defined &Foo::Bar::TableOne::count, 'Table package was not created' );
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=25397&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/lib/Test.pm (original)
+++ branches/upstream/liborlite-perl/current/t/lib/Test.pm Fri Sep 19 20:16:10 2008
@@ -8,7 +8,7 @@
use vars qw{$VERSION @ISA @EXPORT};
BEGIN {
- $VERSION = '0.10';
+ $VERSION = '0.13';
@ISA = qw{ Exporter };
@EXPORT = qw{ test_db connect_ok create_ok };
}
More information about the Pkg-perl-cvs-commits
mailing list