r25399 - in /trunk/liborlite-perl: Changes MANIFEST META.yml debian/changelog 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:18:36 UTC 2008


Author: dmn
Date: Fri Sep 19 20:18:32 2008
New Revision: 25399

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=25399
Log:
New upstream release

Added:
    trunk/liborlite-perl/t/05_notables.t
      - copied unchanged from r25398, branches/upstream/liborlite-perl/current/t/05_notables.t
Modified:
    trunk/liborlite-perl/Changes
    trunk/liborlite-perl/MANIFEST
    trunk/liborlite-perl/META.yml
    trunk/liborlite-perl/debian/changelog
    trunk/liborlite-perl/lib/ORLite.pm
    trunk/liborlite-perl/t/01_compile.t
    trunk/liborlite-perl/t/04_readonly.t
    trunk/liborlite-perl/t/lib/Test.pm

Modified: trunk/liborlite-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/Changes?rev=25399&op=diff
==============================================================================
--- trunk/liborlite-perl/Changes (original)
+++ trunk/liborlite-perl/Changes Fri Sep 19 20:18:32 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: trunk/liborlite-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/MANIFEST?rev=25399&op=diff
==============================================================================
--- trunk/liborlite-perl/MANIFEST (original)
+++ trunk/liborlite-perl/MANIFEST Fri Sep 19 20:18:32 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: trunk/liborlite-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/META.yml?rev=25399&op=diff
==============================================================================
--- trunk/liborlite-perl/META.yml (original)
+++ trunk/liborlite-perl/META.yml Fri Sep 19 20:18:32 2008
@@ -25,4 +25,4 @@
   perl: 5.6.0
 resources:
   license: http://dev.perl.org/licenses/
-version: 0.11
+version: 0.13

Modified: trunk/liborlite-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/debian/changelog?rev=25399&op=diff
==============================================================================
--- trunk/liborlite-perl/debian/changelog (original)
+++ trunk/liborlite-perl/debian/changelog Fri Sep 19 20:18:32 2008
@@ -1,3 +1,9 @@
+liborlite-perl (0.13-1) UNRELEASED; urgency=low
+
+  * New upstream release
+
+ -- Damyan Ivanov <dmn at debian.org>  Fri, 19 Sep 2008 23:16:41 +0300
+
 liborlite-perl (0.11-1) unstable; urgency=low
 
   * Initial Release. Closes: #498921 -- ITP

Modified: trunk/liborlite-perl/lib/ORLite.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/lib/ORLite.pm?rev=25399&op=diff
==============================================================================
--- trunk/liborlite-perl/lib/ORLite.pm (original)
+++ trunk/liborlite-perl/lib/ORLite.pm Fri Sep 19 20:18:32 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: trunk/liborlite-perl/t/01_compile.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/t/01_compile.t?rev=25399&op=diff
==============================================================================
--- trunk/liborlite-perl/t/01_compile.t (original)
+++ trunk/liborlite-perl/t/01_compile.t Fri Sep 19 20:18:32 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: trunk/liborlite-perl/t/04_readonly.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/t/04_readonly.t?rev=25399&op=diff
==============================================================================
--- trunk/liborlite-perl/t/04_readonly.t (original)
+++ trunk/liborlite-perl/t/04_readonly.t Fri Sep 19 20:18:32 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' );

Modified: trunk/liborlite-perl/t/lib/Test.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/t/lib/Test.pm?rev=25399&op=diff
==============================================================================
--- trunk/liborlite-perl/t/lib/Test.pm (original)
+++ trunk/liborlite-perl/t/lib/Test.pm Fri Sep 19 20:18:32 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