r51631 - in /branches/upstream/liborlite-perl/current: Changes MANIFEST META.yml Makefile.PL lib/ORLite.pm t/06_create.t t/08_prune.pl t/10_cleanup.sql t/10_cleanup.t t/11_cleanup.t t/lib/Test.pm

jawnsy-guest at users.alioth.debian.org jawnsy-guest at users.alioth.debian.org
Wed Jan 27 01:50:23 UTC 2010


Author: jawnsy-guest
Date: Wed Jan 27 01:50:18 2010
New Revision: 51631

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=51631
Log:
[svn-upgrade] Integrating new upstream version, liborlite-perl (1.34)

Added:
    branches/upstream/liborlite-perl/current/t/10_cleanup.sql
    branches/upstream/liborlite-perl/current/t/10_cleanup.t
    branches/upstream/liborlite-perl/current/t/11_cleanup.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/Makefile.PL
    branches/upstream/liborlite-perl/current/lib/ORLite.pm
    branches/upstream/liborlite-perl/current/t/06_create.t
    branches/upstream/liborlite-perl/current/t/08_prune.pl
    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=51631&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/Changes (original)
+++ branches/upstream/liborlite-perl/current/Changes Wed Jan 27 01:50:18 2010
@@ -1,4 +1,10 @@
 Changes for Perl extension ORLite
+
+1.34 Tue 26 Jan 2010
+	- Major Change: Moved code generation from raw string appending to
+	  using Template::Tiny instead. This will enable some new and more
+	  complex improvements to the generated code.
+	- Added tests for the cleanup code.
 
 1.33 Sun 24 Jan 2010
 	- When in the Perl debugger and on Perl 5.8.9 or newer,

Modified: branches/upstream/liborlite-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/MANIFEST?rev=51631&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/MANIFEST (original)
+++ branches/upstream/liborlite-perl/current/MANIFEST Wed Jan 27 01:50:18 2010
@@ -28,6 +28,9 @@
 t/08_prune.pl
 t/08_prune.t
 t/09_badfile.t
+t/10_cleanup.sql
+t/10_cleanup.t
+t/11_cleanup.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=51631&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/META.yml (original)
+++ branches/upstream/liborlite-perl/current/META.yml Wed Jan 27 01:50:18 2010
@@ -29,9 +29,10 @@
   File::Spec: 0.80
   File::Temp: 0.20
   Params::Util: 0.33
+  Template::Tiny: 0.09
   perl: 5.6.0
 resources:
   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.33
+version: 1.34

Modified: branches/upstream/liborlite-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/Makefile.PL?rev=51631&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/Makefile.PL (original)
+++ branches/upstream/liborlite-perl/current/Makefile.PL Wed Jan 27 01:50:18 2010
@@ -1,4 +1,4 @@
-use inc::Module::Install::DSL 0.91;
+use inc::Module::Install::DSL 0.92;
 
 all_from      lib/ORLite.pm
 requires_from lib/ORLite.pm

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=51631&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/lib/ORLite.pm (original)
+++ branches/upstream/liborlite-perl/current/lib/ORLite.pm Wed Jan 27 01:50:18 2010
@@ -4,18 +4,19 @@
 
 use 5.006;
 use strict;
-use Carp              ();
-use File::Spec   0.80 ();
-use File::Temp   0.20 ();
-use File::Path   2.04 ();
-use File::Basename  0 ();
-use Params::Util 0.33 ();
-use DBI         1.607 ();
-use DBD::SQLite  1.27 ();
+use Carp                ();
+use File::Spec     0.80 ();
+use File::Temp     0.20 ();
+use File::Path     2.04 ();
+use File::Basename    0 ();
+use Params::Util   0.33 ();
+use Template::Tiny 0.09 ();
+use DBI           1.607 ();
+use DBD::SQLite    1.27 ();
 
 use vars qw{$VERSION};
 BEGIN {
-	$VERSION = '1.33';
+	$VERSION = '1.34';
 }
 
 # Support for the 'prune' option
@@ -45,7 +46,7 @@
 		pop @_;
 	}
 
-	# Check params and apply defaults
+	# Handle param formatting
 	my %params;
 	if ( defined Params::Util::_STRING($_[1]) ) {
 		# Support the short form "use ORLite 'db.sqlite'"
@@ -60,6 +61,11 @@
 	} else {
 		Carp::croak("Missing, empty or invalid params HASH");
 	}
+
+	# Check params and apply defaults
+	$params{orlite} = $VERSION;
+	$params{file}   = File::Spec->rel2abs($params{file});
+	$params{dsn}    = "dbi:SQLite:$params{file}";
 	unless ( defined $params{create} ) {
 		$params{create} = 0;
 	}
@@ -90,22 +96,17 @@
 	}
 
 	# Connect to the database
-	my $file     = File::Spec->rel2abs($params{file});
 	my $created  = ! -f $params{file};
 	if ( $created ) {
 		# Create the parent directory
-		my $dir = File::Basename::dirname($file);
+		my $dir = File::Basename::dirname($params{file});
 		unless ( -d $dir ) {
 			my @dirs = File::Path::mkpath( $dir, { verbose => 0 } );
 			$class->prune(@dirs) if $params{prune};
 		}
-		$class->prune($file) if $params{prune};
-	}
-	my $pkg         = $params{package};
-	my $readonly    = $params{readonly};
-	my $cleanup     = $params{cleanup};
-	my $dsn         = "dbi:SQLite:$file";
-	my $dbh         = DBI->connect( $dsn, undef, undef, {
+		$class->prune($params{file}) if $params{prune};
+	}
+	my $dbh = DBI->connect( $params{dsn}, undef, undef, {
 		PrintError => 0,
 		RaiseError => 1,
 	} );
@@ -116,158 +117,15 @@
 	}
 
 	# Check the schema version before generating
-	my $version  = $dbh->selectrow_arrayref('pragma user_version')->[0];
-	if ( exists $params{user_version} and $version != $params{user_version} ) {
-		Carp::croak("Schema user_version mismatch (got $version, wanted $params{user_version})");
-	}
-
-	# Generate the support package code
-	my $code = <<"END_PERL";
-package $pkg;
-
-use strict;
-use Carp              ();
-use DBI         1.607 ();
-use DBD::SQLite  1.27 ();
-
-my \$DBH = undef;
-
-sub orlite { '$VERSION' }
-
-sub sqlite { '$file' }
-
-sub dsn { '$dsn' }
-
-sub dbh {
-	\$DBH or \$_[0]->connect;
-}
-
-sub connect {
-	DBI->connect( \$_[0]->dsn, undef, undef, {
-		PrintError => 0,
-		RaiseError => 1,
-	} );
-}
-
-sub prepare {
-	shift->dbh->prepare(\@_);
-}
-
-sub do {
-	shift->dbh->do(\@_);
-}
-
-sub selectall_arrayref {
-	shift->dbh->selectall_arrayref(\@_);
-}
-
-sub selectall_hashref {
-	shift->dbh->selectall_hashref(\@_);
-}
-
-sub selectcol_arrayref {
-	shift->dbh->selectcol_arrayref(\@_);
-}
-
-sub selectrow_array {
-	shift->dbh->selectrow_array(\@_);
-}
-
-sub selectrow_arrayref {
-	shift->dbh->selectrow_arrayref(\@_);
-}
-
-sub selectrow_hashref {
-	shift->dbh->selectrow_hashref(\@_);
-}
-
-sub pragma {
-	\$_[0]->do("pragma \$_[1] = \$_[2]") if \@_ > 2;
-	\$_[0]->selectrow_arrayref("pragma \$_[1]")->[0];
-}
-
-sub iterate {
-	my \$class = shift;
-	my \$call  = pop;
-	my \$sth   = \$class->prepare( shift );
-	\$sth->execute( \@_ );
-	while ( \$_ = \$sth->fetchrow_arrayref ) {
-		\$call->() or last;
-	}
-	\$sth->finish;
-}
-
-sub begin {
-	\$DBH or
-	\$DBH = \$_[0]->connect;
-	\$DBH->begin_work;
-}
-
-sub rollback {
-	\$DBH or return 1;
-	\$DBH->rollback;
-	\$DBH->disconnect;
-	undef \$DBH;
-	return 1;
-}
-
-sub rollback_begin {
-	if ( \$DBH ) {
-		\$DBH->rollback;
-		\$DBH->begin_work;
-	} else {
-		\$_[0]->begin;
-	}
-	return 1;
-}
-
-END_PERL
-
-	# If you are a read-write database, we even allow you
-	# to commit your transactions.
-	$code .= <<"END_PERL" unless $readonly;
-sub commit {
-	\$DBH or return 1;
-	\$DBH->commit;
-	\$DBH->disconnect;
-	undef \$DBH;
-	return 1;
-}
-
-sub commit_begin {
-	if ( \$DBH ) {
-		\$DBH->commit;
-		\$DBH->begin_work;
-	} else {
-		\$_[0]->begin;
-	}
-	return 1;
-}
-
-END_PERL
-
-	# Cleanup and shutdown operations
-	if ( $cleanup ) {
-		$code .= <<"END_PERL";
-END {
-	\$dbh->rollback if \$DBH;
-	$pkg->dbh->do('$cleanup');
-}
-
-END_PERL
-	} else {
-		$code .= <<"END_PERL";
-END {
-	$pkg->rollback if \$DBH;
-}
-
-END_PERL
+	my $user_version  = $dbh->selectrow_arrayref('pragma user_version')->[0];
+	if ( exists $params{user_version} and $user_version != $params{user_version} ) {
+		Carp::croak("Schema user_version mismatch (got $user_version, wanted $params{user_version})");
 	}
 
 	# Optionally generate the table classes
 	if ( $params{tables} ) {
 		# Capture the raw schema information
-		my $tables = $dbh->selectall_arrayref(
+		my $tables = $params{tables} = $dbh->selectall_arrayref(
 			'select * from sqlite_master where name not like ? and type = ?',
 			{ Slice => {} }, 'sqlite_%', 'table',
 		);
@@ -289,29 +147,32 @@
 			@{$table->{pk}}  = map($_->{name}, grep { $_->{pk} } @columns);
 			$table->{pks}    = scalar(@{$table->{pk}});
 
+			# Will this table be read-write?
+			$table->{readwrite} = !! ( $table->{pks} and ! $params{readonly} );
+
 			# 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}";
+			$table->{class}  = "$params{package}::$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 ' ',
+			$table->{sql_create}  = $table->{sql};
+			$table->{sql_cols}    = join ', ', map { '"' . $_ . '"' } @names;
+			$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_insert}  = join ' ',
 				"insert into $table->{name}" .
-				"( $table->{sql}->{cols} )"  .
-				" values ( $table->{sql}->{vals} )";
-			$sql->{where_pk}    = join(' and ', map("$_ = ?", @{$table->{pk}}))
+				"( $table->{sql_cols} )"  .
+				" values ( $table->{sql_vals} )";
+			$table->{sql_where_pk} = join(' and ', map("$_ = ?", @{$table->{pk}}))
 		}
 
-		# Generate the foreign key metadata
+		# Generate the foreign key metadata once all the basic table data is complete
 		foreach my $table ( @$tables ) {
 			# Locate the foreign keys
 			my %fk     = ();
-			my @fk_sql = $table->{sql}->{create} =~ /[(,]\s*(.+?REFERENCES.+?)\s*[,)]/g;
+			my @fk_sql = $table->{sql_create} =~ /[(,]\s*(.+?REFERENCES.+?)\s*[,)]/g;
 
 			# Extract the details
 			foreach ( @fk_sql ) {
@@ -326,156 +187,282 @@
 		}
 
 		# 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 base { '$pkg' }
-
-sub table { '$table->{name}' }
+		foreach my $table ( grep { $_->{readwrite} } @$tables ) {
+			# Generate the elements for tables with primary keys
+			my @names = map { $_->{name} } @{ $table->{columns} };
+			$table->{nattr}   = join "\n", map { "\t\t$_ => \$attr{$_}," } @names;
+			$table->{iattr}   = join "\n", map { "\t\t\$self->{$_},"     } @names;
+			$table->{fill_pk} = scalar @{$table->{pk}} == 1 
+				? "\t\$self->{$table->{pk}->[0]} = \$dbh->func('last_insert_rowid') unless \$self->{$table->{pk}->[0]};"
+				: q{};
+			$table->{where_pk} = join(' and ', map("$_ = ?", @{$table->{pk}}));
+			$table->{where_pk_attr} = join("\n", map("\t\t\$self->{$_},", @{$table->{pk}}));
+		}
+	}
+	$dbh->disconnect;
+
+	# Generate as a template.
+	my $code2 = Template::Tiny->new->process( \<<'END_PERL', \%params );
+package [% package %];
+
+use strict;
+use Carp             ();
+use DBI        1.607 ();
+use DBD::SQLite 1.27 ();
+
+my $DBH = undef;
+
+sub orlite { '[% orlite %]' }
+
+sub sqlite { '[% file %]' }
+
+sub dsn { 'dbi:SQLite:[% file %]' }
+
+sub dbh {
+	$DBH or $_[0]->connect;
+}
+
+sub connect {
+	DBI->connect( $_[0]->dsn, undef, undef, {
+		PrintError => 0,
+		RaiseError => 1,
+	} );
+}
+
+sub prepare {
+	shift->dbh->prepare(@_);
+}
+
+sub do {
+	shift->dbh->do(@_);
+}
+
+sub selectall_arrayref {
+	shift->dbh->selectall_arrayref(@_);
+}
+
+sub selectall_hashref {
+	shift->dbh->selectall_hashref(@_);
+}
+
+sub selectcol_arrayref {
+	shift->dbh->selectcol_arrayref(@_);
+}
+
+sub selectrow_array {
+	shift->dbh->selectrow_array(@_);
+}
+
+sub selectrow_arrayref {
+	shift->dbh->selectrow_arrayref(@_);
+}
+
+sub selectrow_hashref {
+	shift->dbh->selectrow_hashref(@_);
+}
+
+sub pragma {
+	$_[0]->do("pragma $_[1] = $_[2]") if @_ > 2;
+	$_[0]->selectrow_arrayref("pragma $_[1]")->[0];
+}
+
+sub iterate {
+	my $class = shift;
+	my $call  = pop;
+	my $sth   = $class->prepare(shift);
+	$sth->execute(@_);
+	while ( $_ = $sth->fetchrow_arrayref ) {
+		$call->() or last;
+	}
+	$sth->finish;
+}
+
+sub begin {
+	$DBH or
+	$DBH = $_[0]->connect;
+	$DBH->begin_work;
+}
+
+sub rollback {
+	$DBH or return 1;
+	$DBH->rollback;
+	$DBH->disconnect;
+	undef $DBH;
+	return 1;
+}
+
+sub rollback_begin {
+	if ( $DBH ) {
+		$DBH->rollback;
+		$DBH->begin_work;
+	} else {
+		$_[0]->begin;
+	}
+	return 1;
+}
+[% UNLESS readonly %]
+sub commit {
+	$DBH or return 1;
+	$DBH->commit;
+	$DBH->disconnect;
+	undef $DBH;
+	return 1;
+}
+
+sub commit_begin {
+	if ( $DBH ) {
+		$DBH->commit;
+		$DBH->begin_work;
+	} else {
+		$_[0]->begin;
+	}
+	return 1;
+}
+[% END %]
+[%- IF cleanup %]
+END {
+	if ( $DBH ) {
+		$DBH->rollback;
+		$DBH->do('[% cleanup %]');
+		$DBH->disconnect;
+		undef $DBH;
+	} else {
+		[% package %]->do('[% cleanup %]');
+	}
+}
+[%- ELSE %]
+END {
+	[% package %]->rollback if $DBH;
+}
+[%- END %]
+[% FOREACH table IN tables %]
+package [% table.class %];
+
+sub base { '[% package %]' }
+
+sub table { '[% table.name %]' }
 
 sub select {
-	my \$class = shift;
-	my \$sql   = '$sql->{select} ';
-	   \$sql  .= shift if \@_;
-	my \$rows  = $pkg->selectall_arrayref( \$sql, { Slice => {} }, \@_ );
-	bless( \$_, '$table->{class}' ) foreach \@\$rows;
-	wantarray ? \@\$rows : \$rows;
+	my $class = shift;
+	my $sql   = '[% table.sql_select %] ';
+	   $sql  .= shift if @_;
+	my $rows  = [% package %]->selectall_arrayref( $sql, { Slice => {} }, @_ );
+	bless( $_, '[% table.class %]' ) foreach @$rows;
+	wantarray ? @$rows : $rows;
 }
 
 sub count {
-	my \$class = shift;
-	my \$sql   = '$sql->{count} ';
-	   \$sql  .= shift if \@_;
-	$pkg->selectrow_array( \$sql, {}, \@_ );
+	my $class = shift;
+	my $sql   = '[% table.sql_count %] ';
+	   $sql  .= shift if @_;
+	[% package %]->selectrow_array( $sql, {}, @_ );
 }
 
 sub iterate {
-	my \$class = shift;
-	my \$call  = pop;
-	my \$sql   = '$sql->{select} ';
-	   \$sql  .= shift if \@_;
-	my \$sth   = $pkg->prepare( \$sql );
-	\$sth->execute( \@_ );
-	while ( \$_ = \$sth->fetchrow_hashref ) {
-		bless( \$_, '$table->{class}' );
-		\$call->() or last;
-	}
-	\$sth->finish;
-}
-
+	my $class = shift;
+	my $call  = pop;
+	my $sql   = '[% table.sql_select %] ';
+	   $sql  .= shift if @_;
+	my $sth   = [% package %]->prepare( $sql );
+	$sth->execute( @_ );
+	while ( $_ = $sth->fetchrow_hashref ) {
+		bless( $_, '[% table.class %]' );
+		$call->() or last;
+	}
+	$sth->finish;
+}
+[% IF table.pks %]
+sub load {
+	my $class = shift;
+	my $row   = [% package %]->selectrow_hashref(
+		'[% table.sql_select %] where [% table.sql_where_pk %]',
+		undef, @_,
+	);
+	unless ( $row ) {
+		Carp::croak("[% table.class %] row does not exist");
+	}
+	bless( $row, '[% table.class %]' );
+}
+[% END %]
+[%- IF table.readwrite %]
+sub new {
+	my $class = shift;
+	my %attr  = @_;
+	bless {
+[% table.nattr %]
+	}, $class;
+}
+
+sub create {
+	shift->new(@_)->insert;
+}
+
+sub insert {
+	my $self = shift;
+	my $dbh  = [% package %]->dbh;
+	$dbh->do( '[% table.sql_insert %]', {},
+[% table.iattr %]
+	);
+[% table.fill_pk %]
+	return $self;
+}
+
+sub delete {
+	my $self = shift;
+	return [% package %]->do(
+		'delete from [% table.name %] where [% table.where_pk %]',
+		{}, 
+[% table.where_pk_attr %]
+	) if ref $self;
+	Carp::croak("Must use truncate to delete all rows") unless @_;
+	return [% package %]->do(
+		'delete from [% table.name %] ' . shift,
+		{}, @_,
+	);
+}
+
+sub truncate {
+	[% package %]->do( 'delete from [% table.name %]', {} );
+}
+[% END %]
+[%- FOREACH column IN table.columns %]
+sub [% column.name %] {
+[%- IF column.fk %]
+	([% column.fk.1.class %]->select('where [% column.fk.1.pk.0 %] = ?', $_[0]->{[% column.name %]}))[0];
+[%- ELSE %]
+	$_[0]->{[% column.name %]};
+[%- END %]
+}
+[% END %]
+[%- END %]
+[%- IF append %]
+[%- IF tables %]
+package [% package %];
+[% END %]
+[% append %]
+[% END %]
+1;
 END_PERL
 
-			# Add the primary key based single object loader
-			if ( $table->{pks} ) {
-				$code .= <<"END_PERL";
-sub load {
-	my \$class = shift;
-	my \$row   = $pkg->selectrow_hashref(
-		'$sql->{select} where $sql->{where_pk}',
-		undef, \@_,
-	);
-	unless ( \$row ) {
-		Carp::croak("$table->{class} row does not exist");
-	}
-	bless( \$row, '$table->{class}' );
-}
-
-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;
-				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 {
-	my \$class = shift;
-	my \%attr  = \@_;
-	bless {
-$nattr
-	}, \$class;
-}
-
-sub create {
-	shift->new(\@_)->insert;
-}
-
-sub insert {
-	my \$self = shift;
-	my \$dbh  = $pkg->dbh;
-	\$dbh->do( '$sql->{insert}', {},
-$iattr
-	);
-$fill_pk	
-	return \$self;
-}
-
-sub delete {
-	my \$self = shift;
-	return $pkg->do(
-		'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(
-		'delete from $table->{name} ' . shift,
-		{}, \@_,
-	);
-}
-
-sub truncate {
-	$pkg->do( 'delete from $table->{name}', {} );
-}
-
-END_PERL
-
-			}
-
-		# 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] = ?', \$_[0]->{$_->{name}}))[0];
-}
-END_DIRECT
-sub $_->{name} {
-	\$_[0]->{$_->{name}};
-}
-END_ACCESSOR
-
-		}
-	}
-	$dbh->disconnect;
-
-	# Add any custom code to the end
-	if ( defined $params{append} ) {
-		$code .= "\npackage $pkg;\n" if $params{tables};
-		$code .= "\n$params{append}";
-	}
-	$code .= "\n\n1;\n";
+	# Comparative testing
+#	if ( $ENV{HARNESS_ACTIVE} ) {
+#		require Test::LongString;
+#		Test::LongString::is_string(
+#			$code2 => $code,
+#			"Templated code matches string-append code",
+#		);
+#	}
 
 	# Compile the code
 	local $@;
 	if ( $^P and $^V >= 5.008009 ) {
 		local $^P = $^P | 0x800;
-		eval $code;
+		eval $code2;
 		die $@ if $@;
 	} elsif ( $DEBUG ) {
-		dval($code);
+		dval($code2);
 	} else {
-		eval $code;
+		eval $code2;
 		die $@ if $@;
 	}
 

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=51631&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/06_create.t (original)
+++ branches/upstream/liborlite-perl/current/t/06_create.t Wed Jan 27 01:50:18 2010
@@ -9,7 +9,7 @@
 	$^W = 1;
 }
 
-use Test::More tests => 20;
+use Test::More tests => 25;
 use File::Spec::Functions ':ALL';
 use t::lib::Test;
 
@@ -112,3 +112,40 @@
 	isa_ok( $create, 'My::Test2::Foo' );
 	is( $create->bar, 3, '->bar ok' );
 }
+
+
+
+
+
+######################################################################
+# Appending with tables
+
+SCOPE: {
+	# Set up the file
+	my $file = test_db();
+	my $dbh  = create_ok(
+		file    => catfile(qw{ t 02_basics.sql }),
+		connect => [ "dbi:SQLite:$file" ],
+	);
+
+	# Create the second test package (with tables)
+	eval <<"END_PERL"; die $@ if $@;
+package My::Test3;
+
+use strict;
+use ORLite {
+	file   => '$file',
+	create => 1,
+	append => 'sub append { 2 }',
+};
+
+1;
+END_PERL
+
+	ok( My::Test3->can('connect'), 'Created read code'  );
+	ok( My::Test3->can('begin'),   'Created write code' );
+	ok( My::Test3::TableOne->can('select'), 'Created table code' );
+
+	# When generating tables, we still append to the right place
+	is( My::Test3->append, 2, 'append params works as expected' );
+}

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=51631&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/08_prune.pl (original)
+++ branches/upstream/liborlite-perl/current/t/08_prune.pl Wed Jan 27 01:50:18 2010
@@ -4,7 +4,7 @@
 
 use strict;
 
-our $VERSION = '1.33';
+our $VERSION = '1.34';
 
 unless ( $ORLite::VERSION eq $VERSION ) {
 	die('Failed to load correct ORLite version');

Added: branches/upstream/liborlite-perl/current/t/10_cleanup.sql
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/10_cleanup.sql?rev=51631&op=file
==============================================================================
--- branches/upstream/liborlite-perl/current/t/10_cleanup.sql (added)
+++ branches/upstream/liborlite-perl/current/t/10_cleanup.sql Wed Jan 27 01:50:18 2010
@@ -1,0 +1,8 @@
+create table table_one (
+	col1 integer not null primary key,
+	col2 string
+);
+
+insert into table_one ( col1, col2 ) values ( 1, 'a' );
+insert into table_one ( col1, col2 ) values ( 2, 'b' );
+insert into table_one ( col1, col2 ) values ( 3, null );

Added: branches/upstream/liborlite-perl/current/t/10_cleanup.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/10_cleanup.t?rev=51631&op=file
==============================================================================
--- branches/upstream/liborlite-perl/current/t/10_cleanup.t (added)
+++ branches/upstream/liborlite-perl/current/t/10_cleanup.t Wed Jan 27 01:50:18 2010
@@ -1,0 +1,43 @@
+#!/usr/bin/perl
+
+# Test that cleanup works
+
+BEGIN {
+	$|  = 1;
+	$^W = 1;
+}
+
+use Test::More tests => 2;
+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 10_cleanup.sql }),
+	connect => [ "dbi:SQLite:$file" ],
+);
+
+# Create the test package
+eval <<"END_PERL"; die $@ if $@;
+package Foo::Bar;
+
+use strict;
+use ORLite {
+	file    => '$file',
+	cleanup => 'VACUUM ANALYZE',
+};
+
+1;
+END_PERL
+
+
+#####################################################################
+# Run the tests
+
+ok( Foo::Bar->can('orlite'), 'Created the ORLite class' );
+

Added: branches/upstream/liborlite-perl/current/t/11_cleanup.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liborlite-perl/current/t/11_cleanup.t?rev=51631&op=file
==============================================================================
--- branches/upstream/liborlite-perl/current/t/11_cleanup.t (added)
+++ branches/upstream/liborlite-perl/current/t/11_cleanup.t Wed Jan 27 01:50:18 2010
@@ -1,0 +1,44 @@
+#!/usr/bin/perl
+
+# Repeat the previous test, this time with a live transaction at END-time
+
+BEGIN {
+	$|  = 1;
+	$^W = 1;
+}
+
+use Test::More tests => 3;
+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 10_cleanup.sql }),
+	connect => [ "dbi:SQLite:$file" ],
+);
+
+# Create the test package
+eval <<"END_PERL"; die $@ if $@;
+package Foo::Bar;
+
+use strict;
+use ORLite {
+	file    => '$file',
+	cleanup => 'VACUUM ANALYZE',
+};
+
+1;
+END_PERL
+
+
+#####################################################################
+# Run the tests
+
+ok( Foo::Bar->can('orlite'), 'Created the ORLite class' );
+
+ok( Foo::Bar->begin, 'Created the transaction' );

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=51631&op=diff
==============================================================================
--- branches/upstream/liborlite-perl/current/t/lib/Test.pm (original)
+++ branches/upstream/liborlite-perl/current/t/lib/Test.pm Wed Jan 27 01:50:18 2010
@@ -1,14 +1,15 @@
 package t::lib::Test;
 
 use strict;
-use Exporter   ();
-use ORLite     ();
-use Test::More ();
+use Exporter     ();
+use ORLite       ();
+use Test::More   ();
+use File::Remove ();
 use File::Spec::Functions ':ALL';
 
 use vars qw{$VERSION @ISA @EXPORT};
 BEGIN {
-	$VERSION = '1.33';
+	$VERSION = '1.34';
 	@ISA     = 'Exporter';
 	@EXPORT  = qw{ test_db connect_ok create_ok };
 }
@@ -23,7 +24,7 @@
 my %to_delete = ();
 END {
 	foreach my $file ( sort keys %to_delete ) {
-		unlink $file;
+		File::Remove::remove($file);
 	}
 }
 




More information about the Pkg-perl-cvs-commits mailing list